home *** CD-ROM | disk | FTP | other *** search
/ The CICA Windows Explosion! / The CICA Windows Explosion! - Disc 2.iso / nt / jx4nt125.zip / JAX4TH.A < prev    next >
Text File  |  1994-10-10  |  132KB  |  5,074 lines

  1.     TITLE    jax4th.a
  2.     PAGE    ,116
  3.  
  4. ; jax4th.a ... 32-bit ANS Forth for Windows NT
  5. ; copyright (c) 1993, 1994 by jack j. woehr
  6. ; p.o. box 51, golden, co 80402-0051
  7. ; jax@well.sf.ca.us | JAX on GEnie | 72203.1320@compuserve.com
  8. ; sysop, rcfb (303) 278-0364
  9.  
  10.     COMMENT    !
  11. This program is free software; you can redistribute it and/or modify
  12. it under the terms of the GNU General Public License as published by
  13. the Free Software Foundation; either version 2 of the License, or
  14. (at your option) any later version.
  15.  
  16. This program is distributed in the hope that it will be useful,
  17. but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19. GNU General Public License for more details. (COPYING.TXT)
  20.  
  21. You should have received a copy of the GNU General Public License
  22. along with this program; if not, write to the Free Software
  23. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */
  24. !
  25.  
  26.     .386P
  27.  
  28.     .XLIST
  29. include listing.inc    ; this may not be needed
  30.     .LIST
  31.  
  32. include jax4th.i
  33.  
  34.     .XLIST
  35. include    windows.i
  36.     .LIST
  37.  
  38. _TEXT    SEGMENT DWORD USE32 PUBLIC 'CODE'
  39. _TEXT    ENDS
  40. _DATA    SEGMENT DWORD USE32 PUBLIC 'DATA'
  41. _DATA    ENDS
  42.  
  43.     .MODEL    FLAT
  44.  
  45. _DATA    SEGMENT DWORD USE32 PUBLIC 'DATA'
  46.  
  47.     .SALL    ; suppress listing of Unicode macro expansion
  48.  
  49. myMsg:        unicode <Jax4th for Windows NT>
  50.         DW 0ah, 0dh
  51.         unicode <Copyright (c) 1993, 1994 Jack J. Woehr>
  52.         DW 0ah, 0dh
  53.         unicode <Covered under the GNU Public License.>
  54.         DW 0ah, 0dh
  55. myMsgLen    = ($-myMsg)/tchar
  56. orderMsg0:    unicode <Search Order: >
  57. orderMsg0Len    = ($-orderMsg0)/tchar
  58. orderMsg1:    unicode <Current Compilation Wordlist: >
  59. orderMsg1Len    = ($-orderMsg1)/tchar
  60. throwMsg:    unicode    <THROW #>
  61. throwMsgLen    = ($-throwMsg)/tchar
  62. byeMsg:        unicode <Goodbye from Jax4th.>
  63.         DW 0ah, 0dh
  64. byeMsgLen    = ($-byeMsg)/tchar
  65. gnuMsg:        unicode < Jax4th $Revision: 1.25 $ (C) 1993, 1994 Jack J. Woehr>
  66.         DW 0ah, 0dh
  67.         unicode < Jax4th comes with ABSOLUTELY NO WARRANTY.>
  68.          DW 0ah, 0dh
  69.            unicode < This is free software, and you are welcome to redistribute it >
  70.         DW 0ah, 0dh
  71.             unicode    < under certain conditions. See file COPYING.TXT for more info.>
  72.         DW 0ah, 0dh
  73.             unicode    < Type ABOUT to see this message again.>
  74.         DW 0ah, 0dh
  75. gnuMsgLen    = ($-gnuMsg)/tchar
  76.  
  77. ;--( Forth Messages )
  78.  
  79. okPrompt    dw    3
  80.         unicode    < ok>
  81. listMsg1    dw    7
  82.         unicode    <Block: >
  83. listMsg2    dw    9
  84.         unicode    <File ID: >
  85. stackUnderMsg    dw    12    
  86.         unicode    <Stack under.>
  87. undefinedMsg    dw    10
  88.         unicode    <Undefined.>
  89. compOnlyMsg    dw    17
  90.         unicode <Compilation only.>
  91. toBodyMsg    dw    22
  92.         unicode    <Not a child of CREATE.>
  93. blockWriteMsg    dw    18
  94.         unicode    <BLOCK write error.>
  95. blockReadMsg    dw    17
  96.         unicode    <BLOCK read error.>
  97. blockNumMsg    dw    21
  98.         unicode    <Invalid BLOCK number.>
  99. fileIOMsg    dw    20
  100.         unicode    <File I/O exception: >
  101. cStackMsg    dw    20
  102.         unicode    <Control stack error.>
  103. conStructMsg    dw    26
  104.         unicode    <Control structure mismatch.>
  105. zeroStringMsg    dw    17
  106.         unicode    <Zero-length name.>
  107. srchOverMsg    dw    22    
  108.         unicode <Search order overflow.>
  109. srchUnderMsg    dw    23
  110.         unicode <Search order underflow.>
  111. compNestMsg    dw    17
  112.         unicode <Compiler nesting.>
  113.  
  114. ;--( Various Messages )
  115.  
  116. dumpHdr        dw    56
  117.         unicode    <Address  0100 0302 0504 0706 0908 0B0A 0D0C 0F0E Unicode>
  118.  
  119. unnamedHdr    dw    3, 0fffeH, 0fffeH, 0fffeH ; invalid name character for headerless
  120.  
  121. widMsg        dw    5
  122.         unicode <named>
  123.  
  124. wlHdr        dw    11
  125.         unicode    <Wordlists: >
  126.     .XALL                ; back to normal listing of macro expansion
  127.  
  128. ;--( Kernel Variables)
  129.  
  130. numWritten    DD    ?                ; for calls to WriteConsoleW
  131. secAttrib    SECURITY_ATTRIBUTES    <>        ; for calls to CreateFileW
  132. fileInfo    _BY_HANDLE_FILE_INFORMATION    <>    ; for calls to GetFileInformationByHandle
  133. saveFile    OPENFILENAME    <>            ; for calls to GetSaveFileName
  134. numRead        DD    ?                ; number of chars read
  135. distMoveHigh    DD    ?                ; used by REPOSITION-FILE
  136. lastReadConW    DW    ?                ; used by KEY and others
  137.  
  138. inRecArray    INPUT_RECORD    256    DUP    (<>)    ; for KEY?
  139.  
  140. _DATA    ENDS
  141.  
  142. _TEXT    SEGMENT DWORD USE32 PUBLIC 'CODE'
  143.  
  144. ;-------------------------------;
  145. ;    Define API Entry    ;
  146. ;-------------------------------;
  147.  
  148. ;PUBLIC    _main        ; satisfies console subsystem
  149.  
  150. ;-----------------------;
  151. ;    Main Program    ;
  152. ;-----------------------;
  153.  
  154. _main    PROC NEAR    ; enter program
  155. ;--( We have to create an NT app exception frame by hand in our assembly-language program.)
  156.     push    ebp
  157.     mov    ebp, esp
  158.     sub    esp, 20
  159.     push    ebx
  160.     push    esi
  161.     push    edi
  162.  
  163. ;--( Now off we go)
  164.     cld            ; !!!***!!! NEXT depends on it, it's this way at boot anyway, but for good luck!
  165.     jmp    boot        ; apropos the above, see MOVE
  166.  
  167. ;---------------;
  168. ;    Forth    ;
  169. ;---------------;
  170.  
  171. ;--( Execution )
  172.  
  173.             ; Implementation detail
  174.     zname    <NEST>    ; this doesn't have an exe engine, it *is* one, musn't be called from Forth interpretively
  175. nest:    pushrp    ip        ; @(--RP) := IP
  176.     lea    ip,cell[wp]    ; IP := @(WP+4)
  177.     next
  178.  
  179.     zname    <DOCONST>        ; -- x    
  180.     push    DWORD PTR cell[wp]    ; Implementation detail
  181.     next                ; Execution engine, works for VARIABLE, also
  182.  
  183.     zname    <DODEFER>        ; i*x -- j*x, deferred word engine
  184.     mov    wp,cell[wp]        ; get exe vector storage offset
  185.     add    wp,dp            ; add base address
  186.     mov    wp,[wp]            ; deref to get token store there
  187.     innext                ; go fer it
  188.     
  189.     zname    <DODOES>        ; -- x        ; Implementation detail
  190.     push    DWORD PTR cell[wp]    ; push data pointer for this CREATE child
  191.     mov    wp,((2*cell))[wp]    ; WP := xt for DOES> code
  192.     dereftok            ; now is a pointer
  193.     jmp    nest        
  194.  
  195.     zname    <UNNEST>    ; -- x    R: nest-sys --
  196.     docode            ; Implementation detail
  197.     poprpto    ip        ; IP := @RP++
  198.     next
  199.  
  200. ; Same routine as above but different name for a debugger to recognize
  201.     fname    <EXIT>        ; --    R: nest-sys --
  202.     docode            ; CORE
  203.     poprpto    ip        ; IP := @RP++
  204.     next
  205.  
  206.     zname    <DOKWORDLIST>    ; -- abs-addr
  207.                 ; Implementation detail, Execution engine for wordlists declared in the kernel
  208.     lea    edx,cell[wp]    ; self-pointer to cell in wordlist code body where data address stored
  209.     push    edx        ; push
  210.     next
  211.  
  212.     zname    <DOWORDLIST>    ; -- a-addr
  213.                 ; Implementation detail, Execution engine for wordlists created by user
  214.     lea    edx,cell[wp]    ; get self-pointer of a Wordlist code body where data address stored
  215.     add    edx,cp        ; convert from user dict address to abs address
  216.     push    eax        ; push
  217.     next
  218.  
  219.     fname    <EXECUTE>    ; i*x xt -- j*x
  220.     docode            ; CORE
  221.     pop    wp
  222.     innext
  223.  
  224.     zname    <DOLIT>        ; -- x
  225.     docode            ; Implementation detail
  226.     lodsd            ; advance instruction pointer fetching literal value
  227.     push    eax        ; push literal
  228.     next
  229.  
  230.     zname    <DODLIT>    ; -- 
  231.     docode            ; Implementation detail
  232.     lodsd            ; advance instruction pointer fetching literal value
  233.     mov    edx,eax        ; save hi 32 bits
  234.     lodsd            ; advance instruction pointer fetching literal value
  235.     push    eax        ; push literal loword
  236.     push    edx        ; push literal hiword
  237.     next
  238.  
  239.     zname    <DOIF>        ; flag -- 
  240.     docode            ; Implementation detail, also is UNTIL
  241.     pop    eax
  242.     and    eax,eax        ; test flag
  243.     je    doelse        ; if zero, we branch
  244.     add    ip,cell        ; wasn't zero, we advance IP
  245.     next
  246.  
  247.     zname    <DOELSE>    ; --
  248.     docode            ; Implementation detail, also is AGAIN, REPEAT
  249. doelse:    mov    wp,[ip]
  250.     dereftok
  251.     mov    ip,wp
  252.     next
  253.  
  254.     zname    <DOUNTIL>    ; flag --
  255.     docode            ; Implementation detail
  256.     pop    eax
  257.     and    eax,eax        ; test flag
  258.     je    doelse        ; if zero, we branch
  259.     add    ip,cell        ; was zero, we advance IP
  260.     next
  261.  
  262.     zname    <DOUNTILNOT>    ; flag --
  263.     docode            ; Implementation detail, used this once, not sure why ..
  264.     pop    eax
  265.     and    eax,eax        ; test flag
  266.     jne    doelse        ; if nonzero, we branch
  267.     add    ip,cell        ; was zero, we advance IP
  268.     next
  269.  
  270.     zname    <DODO>        ; u1 u2 --
  271.     docode            ; Implementation detail
  272. dodo:    lodsd            ; WP := exit address
  273.     dereftok
  274.     pushrp    wp        ; save exit address on return stack
  275.     pop    eax        ; inner loop index
  276.     pop    edx        ; outer loop index
  277.     add    edx,80000000H    ; add overflow limit to outer
  278.     sub    eax,edx        ; massage inner
  279.     pushrp    edx        ; push massaged outer to RStack
  280.     pushrp    eax        ; push massaged inner to RStack
  281.     next
  282.  
  283.     zname    <DOQDO>        ; u1 u2 --
  284.     docode            ; Implementation detail
  285.     mov    edx,[esp]    ; copy of TOS
  286.     cmp    cell[esp],edx    ; compare to other index
  287.     jne    dodo        ; they are different: go ahead and DO
  288.     add    esp,(2*cell)    ; same: clear stack
  289.     lodsd            ; WP := @IP++
  290.     dereftok
  291.     mov    ip,wp        ; IP := WP i.e., exit address compiled in cell ahead of DOQDO token
  292.     next            ; onwards
  293.  
  294.     zname    <DOLOOP>    ; --
  295.     docode            ; Implementation detail
  296. doloop:    poprpto    eax        ; massaged inner index
  297.     inc    eax        ; increment
  298.     jo    doloop1        ; overflow flag, we're done
  299.     pushrp    eax        ; not done, return incremented count
  300.     lodsd            ; WP := @IP++, i.e., WP is loaded with branchback address
  301.     dereftok
  302.     mov    ip,wp        ; IP := branch back
  303.     next            ; continue
  304. doloop1:
  305.     add    rp,(2*cell)    ; clear return stack
  306.     add    ip,cell        ; branch past loopback address
  307.     next            ; onwards and outwards
  308.     
  309.     zname    <DOPLUSLOOP>    ; n1 --
  310.     docode            ; Implementation detail
  311.     poprpto    eax        ; massaged inner index
  312.     pop    edx        ; increment
  313.     add    eax,edx        ; add increment to index
  314.     jo    doloop1        ; overflow flag, we're done, we can re-use the above code
  315.     pushrp    eax        ; not done, return incremented count
  316.     lodsd            ; WP := @IP++, i.e., WP is loaded with branchback address
  317.     dereftok
  318.     mov    ip,wp        ; IP := branch back
  319.     next            ; continue
  320.  
  321. ; Strings for S" and TYPE must reside in data space. In the dictionary they are recorded /DOSQUOTE/D-ADDR/
  322.     zname    <DOSQUOTE>    ; -- c-addr u
  323.     docode            ; Implementation detail
  324.     lodsd            ; count address in ax
  325.     xor    edx,edx        ; clear dx
  326.     mov    dx,[eax][dp]    ; get count
  327.     add    eax,tchar    ; form data address of string
  328.     push    eax        ; push c-addr
  329.     push    edx        ; push u
  330.     next
  331.  
  332.     zname    <DODOTQUOTE>    ; --
  333.     docode            ; Implementation detail
  334.     lodsd            ; count address in wp (EAX)
  335.     xor    edx,edx        ; clear dx
  336.     mov    dx,[eax+dp]    ; get count
  337.     add    eax,tchar    ; form data address of string
  338.     push    eax        ; push c-addr
  339.     push    edx        ; push u
  340.     jmp    ftype        ; goto type
  341.  
  342.     zname    <DOKDOTQUOTE>    ; --        Print strings stored in the kernel exe data section
  343.     docode            ; Implementation detail.
  344.     lodsd            ; count address in wp (EAX)
  345.     sub    eax,dp        ; convert to data-relative address
  346.     xor    edx,edx        ; clear dx
  347.     mov    dx,[eax+dp]    ; get count
  348.     add    eax,tchar    ; form data address of string
  349.     push    eax        ; push c-addr
  350.     push    edx        ; push u
  351.     jmp    ftype        ; goto typ
  352.     
  353. ;--( Stack Operators )
  354.  
  355.     fname    <DROP>        ; x --
  356.     docode            ; CORE
  357.     pop    eax
  358.     next
  359.  
  360.     fnamemanque    <2DROP>    ; x1 x2 --
  361. fw_TWO_DROP:
  362.     docode            ; CORE
  363.     pop    eax
  364.     pop    eax
  365.     next
  366.  
  367.     fnamemanque    <?DUP>    ; x -- x x | 0
  368. fw_QDUP:
  369.     docode            ; CORE
  370.     cmp    DWORD PTR [esp],0
  371.     jne    dupe
  372.     next
  373.  
  374.     fname    <DUP>        ; x -- x x
  375.     docode            ; CORE
  376. dupe:    push    [esp]
  377.     next
  378.  
  379.     fnamemanque    <2DUP>    ; x1 x2 -- x1 x2 x1 x2
  380. fw_TWO_DUP:
  381.     docode            ; CORE
  382.     push    cell[esp]
  383.     push    cell[esp]
  384.     next
  385.  
  386.     fname    <OVER>        ; x1 x2 -- x1 x2 x1
  387.     dd    over        ; CORE
  388. over:    push    cell[esp]
  389.     next
  390.  
  391.     fnamemanque    <2OVER>    ; x1 x2 x3 x4-- x1 x2 x3 x4 x1 x2
  392. fw_TWO_OVER:
  393.     docode            ; CORE
  394.     push    (3*cell)[esp]
  395.     push    (3*cell)[esp]
  396.     next
  397.  
  398.     fname    <ROT>        ; x1 x2 x3 -- x2 x3 x1
  399.     docode            ; CORE
  400.     pop    eax
  401.     pop    ecx
  402.     pop    edx
  403.     push    ecx
  404.     push    eax
  405.     push    edx
  406.     next
  407.  
  408.     nnamemanque    <-ROT>    ; x1 x2 x3 -- x3 x1 x2
  409. fw_NEGROT:            ; Not in Standard
  410.     docode
  411.     pop    eax
  412.     pop    ecx
  413.     pop    edx
  414.     push    eax
  415.     push    edx
  416.     push    ecx
  417.     next
  418.  
  419.     fname    <SWAP>        ; x1 x2 -- x2 x1
  420.     docode            ; CORE
  421.     pop    eax
  422.     pop    edx
  423.     push    eax
  424.     push    edx
  425.     next
  426.  
  427.     fnamemanque    <2SWAP>    ; x1 x2 x3 x4-- x3 x4 x1 x2
  428. fw_TWO_SWAP:            ; CORE
  429.     docode
  430.     mov    eax,(3*cell)[esp]
  431.     mov    edx,cell[esp]
  432.     mov    (3*cell)[esp],edx
  433.     mov    cell[esp],eax
  434.     mov    eax,((2*cell))[esp]
  435.     mov    edx,[esp]
  436.     mov    ((2*cell))[esp],edx
  437.     mov    [esp],eax
  438.     next
  439.  
  440. ; Can't use our name header macros with this one!
  441.     linkme    flinkptr
  442.     countcell    2
  443.     db    '>',0,'R',0    ; x --    R: -- x
  444.     align    4        ; CORE
  445. fw_TO_R:
  446.     docode
  447.     sub    rp,cell
  448.     pop    [rp]
  449.     next
  450.  
  451. ; Can't use our name header macros with this one!
  452.     linkme    flinkptr
  453.     countcell    3
  454.     db    '2',0,'>',0,'R',0    ; x1 x2 --    R: -- x1 x2
  455.     align    4            ; CORE EXT
  456. fw_TWO_TO_R:
  457.     docode
  458.     pop    eax
  459.     sub    rp,cell
  460.     pop    [rp]
  461.     sub    rp,cell
  462.     mov    [rp],eax
  463.     next
  464.  
  465. ; Can't use our name header macros with this one!
  466.     linkme    flinkptr
  467.     countcell    2
  468.     db    'R',0,'>',0    ; -- x    R: x --
  469.     align    4        ; CORE
  470. fw_R_FROM:
  471.     docode
  472.     push    [rp]
  473.     add    rp,cell
  474.     next
  475.  
  476. ; Can't use our name header macros with this one!
  477.     linkme    flinkptr
  478.     countcell    3
  479.     db    '2',0,'R',0,'>',0    ; -- x1 x2    R: x1 x2 --
  480.     align    4            ; CORE EXT
  481. fw_TWO_R_FROM:
  482.     docode
  483.     mov    eax,[rp]
  484.     add    rp,cell
  485.     push    [rp]
  486.     add    rp,cell
  487.     push    eax
  488.     next
  489.  
  490.     fnamemanque    <R@>    ; -- x    R: x -- x
  491. fw_R_FETCH:            ; CORE
  492.     docode        
  493.     push    DWORD PTR [rp]
  494.     next
  495.  
  496. ; Can't use our name header macros with this one!
  497.     linkme    nlinkptr
  498.     countcell    3
  499.     db    'R',0,'P',0,'!',0    ; addr --
  500.     align    4            ; Implementation
  501. fw_RP_STORE:
  502.     docode
  503.     pop    rp
  504.     next
  505.  
  506.     nnamemanque    <RP@>
  507. fw_RP_FETCH:            ; -- addr
  508.     docode            ; Implementation
  509.     push    rp
  510.     next
  511.  
  512.     fname    <TUCK>        ; x1 x2 -- x2 x1 x2
  513.     docode            ; CORE EXT
  514.     pop    eax
  515.     pop    edx
  516.     push    eax
  517.     push    edx
  518.     push    eax
  519.     next
  520.  
  521.     fname    <NIP>        ; x1 x2 -- x2
  522.     docode            ; CORE EXT
  523.     pop    eax
  524.     pop    edx
  525.     push    eax
  526.     next
  527.  
  528.     fname    <PICK>        ; xu .. x1 x0 u -- xu .. x1 x0 xu
  529.     docode            ; CORE EXT
  530.     pop    eax
  531.     push    [esp][eax*cell]
  532.     next
  533.     
  534.     fname    <DEPTH>        ; i*x -- i*x i
  535.     ctok    NEST        ; CORE
  536.     ctok    SP_FETCH    ; -- @esp
  537.     ctok    SP0
  538.     ctok    FETCH        ; -- @esp @orig-esp
  539.     ctok    SWAP
  540.     ctok    MINUS        ; -- diff
  541.     literal    1
  542.     ctok    CELLS        ; -- diff cell-size
  543.     ctok    SLASH        ; -- cells-diff
  544.     ctok    UNNEST
  545.  
  546. ; Get current data stack pointer value, an absolute address
  547.     nnamemanque    <SP@>    ; -- abs-addr
  548. fw_SP_FETCH:            ; Not in Standard
  549.     docode
  550.     push    esp
  551.     next
  552.  
  553. ; Can't use our name header macros with this one!
  554.     linkme    nlinkptr
  555.     countcell    3
  556.     db    'S',0,'P',0,'!'    ; abs-addr --    Set data stack pointer value, an absolute address
  557.     align    4
  558. fw_SP_STORE:            ; Not in Standard
  559.     docode
  560.     pop    esp
  561.     next
  562.  
  563. ; Get saved-at-boot data stack pointer value
  564.     nname    <SP0>        ; -- a-addr
  565.     ctok    DOCONST        ; Not in Standard
  566.     dd    ntConESP
  567.  
  568. ;--( Data Movement )
  569.  
  570. ; Can't use our name header macros with this one!
  571.     linkme    flinkptr
  572.     countcell    1
  573.     db    '!',0        ; x a-addr --
  574.     align    4        ; CORE
  575. fw_STORE:
  576.     docode
  577.     pop    eax
  578.     pop    [eax][dp]
  579.     next
  580.  
  581. ; Can't use our name header macros with this one!
  582.     linkme    flinkptr
  583.     countcell    2
  584.     db    '+',0,'!',0    ; x a-addr --
  585.     align    4        ; CORE
  586. fw_PL_STORE:
  587.     docode
  588.     pop    eax
  589.     pop    edx
  590.     add    [eax][dp],edx
  591.     next
  592.  
  593.     fnamemanque    <@>    ; a-addr -- x
  594. fw_FETCH:
  595.     docode            ; CORE
  596.     pop    eax
  597.     push    [eax][dp]
  598.     next
  599.  
  600. ; Can't use our name header macros with this one!
  601.     linkme    flinkptr
  602.     countcell    2
  603.     db    'C',0,'!',0    ; c c-addr --
  604.     align    4        ; CORE
  605. fw_C_STORE:
  606.     docode
  607.     pop    eax
  608.     pop    edx
  609.     mov    [eax][dp],dx
  610.     next
  611.  
  612.     fnamemanque    <C@>    ; c-addr -- c
  613. fw_C_FETCH:
  614.     docode            ; CORE
  615.     mov    eax,[esp]
  616.     mov    dx,[eax][dp]
  617.     movzx    eax,dx
  618.     mov    [esp],eax    
  619.     next
  620.  
  621. ; Can't use our name header macros with this one!
  622.     linkme    nlinkptr
  623.     countcell    2
  624.     db    'B',0,'!',0    ; byte c-addr --
  625.     align    4        ; Not in Standard
  626. fw_B_STORE:
  627.     docode
  628.     pop    eax
  629.     pop    edx
  630.     mov    [eax][dp],dl
  631.     next
  632.  
  633.     nnamemanque    <B@>    ; c-addr -- byte
  634. fw_B_FETCH:
  635.     docode            ; Not in Standard
  636.     mov    eax,[esp]
  637.     mov    dl,[eax][dp]
  638.     movzx    eax,dl    
  639.     mov    [esp],eax    
  640.     next
  641.  
  642. ; Can't use our name header macros with this one!
  643.     linkme    flinkptr
  644.     countcell    2
  645.     db    '2',0,'!',0    ; x1 x2 a-addr --
  646.     align    4        ; CORE
  647. fw_TWO_STORE:
  648.     docode
  649.     pop    eax
  650.     pop    [eax][dp]
  651.     pop    [eax+cell][dp]
  652.     next
  653.  
  654.     fnamemanque    <2@>    ; a-addr -- x1 x2
  655. fw_TWO_FETCH:
  656.     docode            ; CORE
  657.     pop    eax
  658.     push    [eax+cell][dp]
  659.     push    [eax][dp]
  660.     next
  661.  
  662. ; Can't use our name header macros with this one!
  663.     linkme    flinkptr
  664.     countcell    1
  665.     db    ',',0        ; x --
  666.     align    4        ; CORE
  667. fw_COMMA:
  668.     docode
  669.     mov    eax,[dp+datap]            ; get data space pointer
  670.     pop    [eax][dp]            ; pop to that offset in data space
  671.     add    DWORD PTR datap[dp],cell    ; post-increment pointer
  672.     next
  673.  
  674. ; Can't use our name header macros with this one!
  675.     linkme    flinkptr
  676.     countcell    2
  677.     db    'C',0,',',0    ; char --
  678.     align    4        ; CORE
  679. fw_CCOMMA:
  680.     docode
  681.     mov    eax,[dp+datap]            ; get data space pointer
  682.     pop    edx                ; get char
  683.     mov    [eax][dp],dx            ; pop char to that offset in data space
  684.     add    DWORD PTR datap[dp],tchar    ; post-increment pointer
  685.     next
  686.  
  687.     fname    <MOVE>        ; addr1 addr2 u --
  688.     docode
  689.     pop    ecx        ; count
  690.     pop    eax        ; destination
  691.     pop    edx        ; source
  692.     and    ecx,ecx        ; is count zero?
  693.     je    move2        ; if zero count, exit
  694.     cld            ; now set to move string upwards
  695.     cmp    eax,edx        ; destination - source
  696.     jb    move1        ; jump if destination < source, continue further on
  697.     add    eax,ecx
  698.     dec    eax
  699.     add    edx,ecx
  700.     dec    edx
  701.     std            ; destination >= source, copy downwards
  702. move1:    add    eax,dp        ; absolute destination
  703.     add    edx,dp        ; absolute source
  704.     push    edi        ; save edi
  705.     push    esi        ; save esi
  706.     push    edx        ; load source
  707.     pop    esi
  708.     push    eax        ; load dest
  709.     pop    edi
  710.     push    ds        ; same seg ..
  711.     pop    es        ; .. for source and dest
  712.     rep    movsb        ; copy address units ... this can be optimized later
  713.     pop    esi        ; restore esi
  714.     pop    edi        ; restore edi
  715.     cld            ; !!!***!!! VERY IMPORTANT because NEST depends on it !!!***!!!
  716. move2:    next
  717.  
  718. ;--( Comparisons )
  719.  
  720. ; Can't use our name header macros with this one!
  721.     linkme    flinkptr
  722.     countcell    2
  723.     db    '0',0,'<',0    ; x -- flag
  724.     align    4        ; CORE
  725. fw_ZEROLT:
  726.     docode
  727.     mov    eax,[esp]
  728.     shl    eax,1
  729.     sbb    edx,edx
  730.     mov    [esp],edx
  731.     next
  732.  
  733.     fnamemanque    <0=>    ; x -- flag
  734. fw_ZEROEQ:
  735.     docode            ; CORE
  736.     mov    eax,[esp]
  737.     and    eax,eax
  738.     je    zeroeq1
  739.     mov    DWORD PTR [esp],FALSE
  740.     next
  741. zeroeq1:
  742.     mov    DWORD PTR [esp],TRUE
  743.     next
  744.  
  745. ; Can't use our name header macros with this one!
  746.     linkme    flinkptr
  747.     countcell    3
  748.     db    '0',0,'<',0,'>',0    ; x -- flag
  749.     align    4            ; CORE EXT
  750. fw_ZERONE:
  751.     docode
  752.     mov    eax,[esp]
  753.     and    eax,eax
  754.     jne    zeroeq1            ; reuse code above
  755.     mov    DWORD PTR [esp],FALSE
  756.     next
  757.  
  758. ; Can't use our name header macros with this one!
  759.     linkme    flinkptr
  760.     countcell    2
  761.     db    '0',0,'>',0    ; x -- flag
  762.     align    4        ; CORE EXT
  763. fw_ZEROGT:
  764.     ctok    NEST
  765.     ctok    DUP        ; -- x x
  766.     ctok    ZEROLT        ; -- x flag
  767.     ctok    SWAP        ; -- flag x
  768.     ctok    ZEROEQ        ; -- flag1 flag2
  769.     ctok    OR        ; -- flag
  770.     ctok    ZEROEQ        ; -- flag'
  771.     ctok    UNNEST
  772.  
  773. ; Can't use our name header macros with this one!
  774.     linkme    flinkptr
  775.     countcell    1
  776.     db    '<',0        ; n1 n2 -- flag
  777.     align    4        ; CORE
  778. fw_LESS:
  779.     docode
  780.     pop    eax
  781.     mov    edx,[esp]
  782.     cmp    edx,eax
  783.     jl    less1
  784.     mov    DWORD PTR [esp],FALSE
  785.     next
  786. less1:    mov    DWORD PTR [esp],TRUE
  787.     next
  788.  
  789. ; Can't use our name header macros with this one!
  790.     linkme    flinkptr
  791.     countcell    2
  792.     db    'U',0,'<',0    ; u1 u2 -- flag
  793.     align    4        ; CORE
  794. fw_U_LESS:
  795.     docode
  796.     pop    eax
  797.     mov    edx,[esp]
  798.     cmp    edx,eax
  799.     jb    less1        ; we can re-use code from above
  800.     mov    DWORD PTR [esp],FALSE
  801.     next
  802.  
  803. ; Can't use our name header macros with this one!
  804.     linkme    nlinkptr
  805.     countcell    3
  806.     db    'U',0,'D',0,'<',0    ; ud1 ud2 -- flag
  807.     align    4        ; Not in standard
  808. fw_UD_LESS:
  809.     docode
  810.     pop    edx        ; ud2h
  811.     pop    eax        ; ud2l
  812.     pop    ecx        ; ud1h
  813.     cmp    edx,ecx        ; ud2h
  814.     ja    udless        ; if ud2h > ud1h, TRUE
  815.     jb    nudless        ; if ud2h < ud1h, FALSE
  816.     cmp    eax,[esp]    ; they were equal, try low half
  817.     ja    udless        ; now if ud2l > ud1l, TRUE
  818. nudless:            ; ud2l =< ud1l, FALSE
  819.     mov    DWORD PTR [esp],FALSE
  820.     next
  821. udless:    mov    DWORD PTR [esp],TRUE
  822.     next
  823.  
  824.     nname    <UDMIN>        ; ud1 ud2 -- ud1|ud2
  825.     ctok    NEST        ; Not in standard
  826.     ctok    TWO_OVER
  827.     ctok    TWO_OVER    ; -- ud1 ud2 ud1 ud2
  828.     ctok    D_EQUAL        ; -- ud1 ud2 flag
  829.     compif    udmin1        ; they're the same, drop the top
  830.     ctok    TWO_DROP
  831.     ctok    EXIT
  832. udmin1:
  833.     ctok    TWO_OVER
  834.     ctok    TWO_OVER    ; -- ud1 ud2 ud1 ud2
  835.     ctok    UD_LESS        ; -- ud1 ud2 flag
  836.     compif    udmin2        ; is ud1 ud< u2?
  837.     ctok    TWO_DROP    ; -- ud1, yes, leave ud1
  838.     ctok    EXIT
  839. udmin2:                ; no, so ud1 u> ud2
  840.     ctok    ROT
  841.     ctok    DROP
  842.     ctok    ROT
  843.     ctok    DROP        ; -- ud2
  844.     ctok    UNNEST
  845.  
  846. ; Can't use our name header macros with this one!
  847.     linkme    flinkptr
  848.     countcell    2
  849.     db    'D',0,'=',0        ; xd1 xd2 -- flag
  850.     align    4            ; DOUBLE
  851. fw_D_EQUAL:
  852.     docode
  853.     pop    edx            ; d2h
  854.     pop    eax            ; d2l
  855.     pop    ecx            ; d1h
  856.     cmp    edx,ecx            ; d2h == d1h?
  857.     jne    dnequal            ; no
  858.     cmp    eax,[esp]        ; yes, try lower
  859.     jne    dnequal            ; d2l != d1l
  860.     mov    DWORD PTR [esp],TRUE    ; d2l == d1l
  861.     next
  862. dnequal:
  863.     mov    DWORD PTR [esp],FALSE
  864.     next
  865.  
  866.     fnamemanque    <D0=>    ; xd -- flag
  867. fw_D_ZEROEQ:            ; DOUBLE
  868.     docode
  869.     pop    eax
  870.     and    eax,eax
  871.     jne    dzeroeq1
  872.     or    eax,[esp]
  873.     jne    dzeroeq1
  874.     mov    DWORD PTR [esp],TRUE
  875.     next
  876. dzeroeq1:
  877.     mov    DWORD PTR [esp],FALSE
  878.     next
  879.  
  880. ; Can't use our name header macros with this one!
  881.     linkme    flinkptr
  882.     countcell    1
  883.     db    '=',0        ; x1 x2 -- flag
  884.     align    4        ; CORE
  885. fw_EQUAL:
  886.     docode
  887.     pop    eax
  888.     mov    edx,[esp]
  889.     cmp    eax,edx
  890.     je    equal1
  891.     mov    DWORD PTR [esp],FALSE
  892.     next
  893. equal1:    mov    DWORD PTR [esp],TRUE
  894.     next
  895.  
  896. ; Can't use our name header macros with this one!
  897.     linkme    flinkptr
  898.     countcell    2
  899.     db    '<',0,'>',0    ; x1 x2 -- flag
  900.     align    4        ; CORE EXT
  901. fw_NEQUAL:
  902.     docode
  903.     pop    eax
  904.     mov    edx,[esp]
  905.     cmp    eax,edx
  906.     jne    equal1            ; re-using above code
  907.     mov    DWORD PTR [esp],FALSE
  908.     next
  909.  
  910.  
  911. ; Can't use our name header macros with this one!
  912.     linkme    flinkptr
  913.     countcell    1
  914.     db    '>',0        ; n1 n2 -- flag
  915.     align    4        ; CORE
  916. fw_GREATER:
  917.     docode
  918.     pop    eax
  919.     mov    edx,[esp]
  920.     cmp    edx,eax
  921.     jg    greater1
  922.     mov    DWORD PTR [esp],FALSE
  923.     next
  924. greater1:
  925.     mov    DWORD PTR [esp],TRUE
  926.     next
  927.  
  928.     fname    <MAX>        ; n1 n2 -- n3
  929.     docode            ; CORE
  930.     pop    eax
  931.     pop    edx
  932.     cmp    eax,edx
  933.     jl    f_max1
  934.     push    eax
  935.     next
  936. f_max1:    push    edx
  937.     next
  938.  
  939.     fname    <MIN>        ; n1 n2 -- n3
  940.     docode            ; CORE
  941.     pop    edx
  942.     pop    eax
  943.     cmp    eax,edx
  944.     jg    f_max1        ; reuse code from above
  945.     push    eax
  946.     next
  947.  
  948.     fname    <WITHIN>    ; n|u1 n|u2 n|u3 -- flag
  949.     ctok    NEST        ; CORE EXT
  950.     ctok    OVER
  951.     ctok    MINUS        ; -- n1 n2 diffn3n2
  952.     ctok    TO_R        ; -- n1 n2            R: -- diffn3n2
  953.     ctok    MINUS        ; -- diffn1n2            R: -- diffn3n2
  954.     ctok    R_FROM        ; -- diffn1n2 diffn3n2        R: --
  955.     ctok    U_LESS        ; -- flag
  956.     ctok    UNNEST
  957.  
  958. ;--( Integer Math )
  959.  
  960.     fnamemanque    <1+>    ; n|u1 -- n|u2
  961. fw_ONE_PLUS:
  962.     docode
  963.     add    DWORD PTR [esp],1
  964.     next
  965.  
  966.     fnamemanque    <1->    ; n|u1 -- n|u2
  967. fw_ONE_MINUS:
  968.     docode
  969.     sub    DWORD PTR [esp],1
  970.     next
  971.  
  972.     fname    <ABS>        ; n -- u
  973.     ctok    NEST        ; CORE
  974.     ctok    DUP
  975.     ctok    ZEROLT        ; -- n flag
  976.     compif    abs1
  977.     ctok    NEGATE
  978. abs1:    ctok    UNNEST        ; -- _n_
  979.  
  980.     fname    <DABS>        ; d -- ud
  981.     ctok    NEST        ; DOUBLE
  982.     ctok    DUP
  983.     ctok    ZEROLT        ; -- d flag
  984.     compif    dabs1
  985.     ctok    DNEGATE
  986. dabs1:    ctok    UNNEST        ; -- _d_
  987.  
  988. ; Can't use our name header macros with this one!
  989.     linkme    flinkptr
  990.     countcell    3
  991.     db    'S',0,'>',0,'D',0    ; n1 -- d1
  992.     align    4            ; CORE
  993. fw_S_TO_D:
  994.     docode
  995.     mov    eax,[esp]
  996.     cdq
  997.     push    edx
  998.     next
  999.  
  1000. ; Can't use our name header macros with this one!
  1001.     linkme    flinkptr
  1002.     countcell    3
  1003.     db    'D',0,'>',0,'S',0    ; d1 -- s1
  1004.     align    4            ; DOUBLE
  1005. fw_D_TO_S:
  1006.     docode
  1007.     pop    eax
  1008.     next
  1009.  
  1010.     fname    <NEGATE>    ; n1 -- n2
  1011.     docode            ; CORE
  1012.     mov    eax,[esp]
  1013.     neg    eax
  1014.     mov    [esp],eax
  1015.     next
  1016.  
  1017.     fname    <DNEGATE>    ; d1 -- d2
  1018.     docode            ; DOUBLE
  1019.     xor    eax,eax
  1020.     xor    edx,edx
  1021.     sub    eax,cell[esp]
  1022.     sbb    edx,[esp]
  1023.     mov    cell[esp],eax
  1024.     mov    [esp],edx
  1025.     next    
  1026.  
  1027.     fnamemanque    <+>    ; n|u1 n|u2 -- n|u3
  1028. fw_PLUS:            ; CORE
  1029.     docode
  1030.     pop    eax
  1031.     add    [esp],eax
  1032.     next
  1033.  
  1034.     fnamemanque    <D+>    ; ud|d1 ud|d2 -- ud|d3
  1035. fw_D_PLUS:            ; DOUBLE
  1036.     docode
  1037.     pop    edx            ; d2h
  1038.     pop    eax            ; d2l
  1039.     add    cell[esp],eax        ; d1l+d2l
  1040.     adc    [esp],edx        ; d1h+d2h+carry
  1041.     next
  1042.  
  1043.     fnamemanque    <->    ; n|u1 n|u2 -- n|u3
  1044. fw_MINUS:            ; CORE
  1045.     docode
  1046.     pop    eax
  1047.     sub    [esp],eax
  1048.     next
  1049.  
  1050.     fnamemanque    <D->    ; ud|d1 ud|d2 -- ud|d3
  1051. fw_D_MINUS:            ; DOUBLE
  1052.     docode
  1053.     pop    edx        ; d2h
  1054.     pop    eax        ; d2l
  1055.     sub    cell[esp],eax    ; d1l-d2l
  1056.     sbb    [esp],edx    ; d1h-d2h-borrow
  1057.     next
  1058.  
  1059.     fnamemanque    <*>    ; n|u1 n|u2 -- n|u3
  1060. fw_STAR:            ; CORE
  1061.     docode    
  1062.     pop    eax
  1063.     imul    DWORD PTR[esp]
  1064.     mov    [esp],eax
  1065.     next
  1066.  
  1067.     fnamemanque    </>    ; n1 n2 -- n3
  1068. fw_SLASH:            ; CORE
  1069.     docode
  1070.     pop    ecx        ; n2
  1071.     pop    eax        ; n1
  1072.     cdq            ; high order for div
  1073.     idiv    ecx        ; n1 / n2
  1074.     push    eax        ; quotient
  1075.     next            ; -- n3
  1076.  
  1077.     fnamemanque    </MOD>    ; n1 n2 -- n3 n4
  1078. fw_SLMOD:            ; CORE
  1079.     docode
  1080.     pop    ecx        ; n2
  1081.     pop    eax        ; n1
  1082.     cdq            ; high order for div
  1083.     idiv    ecx        ; n1 / n2
  1084.     push    edx        ; remainder
  1085.     push    eax        ; quotient
  1086.     next            ; -- n3 n4
  1087.  
  1088.     fname    <MOD>        ; n1 n2 -- n3
  1089.     ctok    NEST
  1090.     ctok    SLMOD
  1091.     ctok    DROP
  1092.     ctok    UNNEST
  1093.  
  1094.     fnamemanque    <*/>    ; n1 n2 n3 -- n4
  1095. fw_STARSL:            ; CORE
  1096.     docode
  1097.     pop    ecx        ; n3
  1098.     pop    edx        ; n2
  1099.     pop    eax        ; n1
  1100.     imul    edx        ; n1 * n2
  1101.     idiv    ecx        ; intermediate / n3
  1102.     push    eax        ; quotient
  1103.     next            ; -- n4
  1104.  
  1105.     fnamemanque    <*/MOD>    ; n1 n2 n3 -- n4 n5
  1106. fw_STARSLMOD:            ; CORE
  1107.     docode
  1108.     pop    ecx        ; n3
  1109.     pop    edx        ; n2
  1110.     pop    eax        ; n1
  1111.     imul    edx        ; n1 * n2        
  1112.     idiv    ecx        ; intermediate / n3
  1113.     push    edx        ; remainder
  1114.     push    eax        ; quotient
  1115.     next            ; -- n4 n5
  1116.  
  1117.          nnamemanque    <DUM/MOD>    ; d1 n1 -- n2 d2
  1118. fw_DUMSLMOD:                ; not in Standard
  1119.     ctok    NEST
  1120.     ctok    TO_R            ; -- d1l d1h        R: -- n1
  1121.     literal    0            ; -- d1l d1h 0        R: -- n1
  1122.     ctok    R_FETCH            ; -- d1l d1h 0 n1    R: -- n1
  1123.     ctok    UMSLMOD            ; -- d1l r1 q1        R: -- n1
  1124.     ctok    R_FROM            ; -- d1l r1 q1 n1    R: --
  1125.     ctok    SWAP            ; -- d1l r1 n1 q1    R: --
  1126.     ctok    TO_R            ; -- d1l r1 n1        R: -- d2h
  1127.     ctok    UMSLMOD            ; -- r2 q2        R: -- d2h
  1128.     ctok    R_FROM            ; -- n2 d2
  1129.     ctok    UNNEST            ; -- n2 d2
  1130.  
  1131.     fnamemanque    <FM/MOD>    ; d1 n1 -- n2 n3
  1132. fw_FMSLMOD:                ; CORE
  1133.     ctok    NEST
  1134.     ctok    DUP            ; -- d1    n1
  1135.     ctok    TO_R            ; -- d1    n1        R: -- n1
  1136.     ctok    ZEROLT            ; -- d1    flag        R: -- n1
  1137.     compif    fmslmod1
  1138.     ctok    DNEGATE
  1139. fmslmod1:
  1140.     ctok    S_TO_D            ; -- d1l d1hl d1hh        R: -- n1
  1141.     ctok    R_FETCH            ; -- d1l d1hl d1hh n1        R: -- n1
  1142.     ctok    ABS            ; -- d1l d1hl d1hh _n1_        R: -- n1
  1143.     ctok    AND            ; -- d1l d1hl d1hh _n1_        R: -- n1
  1144.     ctok    PLUS            ; -- d1l intermed        R: -- n1
  1145.     ctok    R_FETCH            ; -- d1l intermed n1        R: -- n1
  1146.     ctok    ABS            ; -- d1l intermed _n1_        R: -- n1
  1147.     ctok    UMSLMOD            ; -- n2' n3            R: -- n1
  1148.     ctok    SWAP            ; -- n3 n2'            R: -- n1
  1149.     ctok    R_FROM            ; -- n3 n2' n1            R: --
  1150.     ctok    ZEROLT            ; -- n3 n2' flag
  1151.     compif    fmslmod2
  1152.     ctok    NEGATE            ; -- n3 n2
  1153. fmslmod2:
  1154.     ctok    SWAP            ; -- n2 n3
  1155.     ctok    UNNEST
  1156.  
  1157.     fnamemanque    <SM/REM>    ; d1 n1 -- n2 n3
  1158. fw_SMSLREM:                ; CORE
  1159.     docode
  1160.     pop    ecx        ; u1
  1161.     pop    edx        ; udh
  1162.     pop    eax        ; udl
  1163.     idiv    ecx
  1164.     push    edx        ; remainder
  1165.     push    eax        ; quotient
  1166.     next            ; -- u2 u3
  1167.  
  1168.     fnamemanque    <UM*>    ; u1 u2 -- ud
  1169. fw_UMSTAR:            ; CORE
  1170.     docode
  1171.     mov    eax,cell[esp]    ; u1
  1172.     mul    DWORD PTR [esp]    ; u1*u2
  1173.     mov    cell[esp],eax    ; udl
  1174.     mov    [esp],edx    ; udh
  1175.     next            ; -- ud
  1176.  
  1177.     fnamemanque    <UM/MOD>    ; ud u1 -- u2 u3)
  1178. fw_UMSLMOD:                ; CORE
  1179.     docode
  1180.     pop    ecx        ; u1
  1181.     pop    edx        ; udh
  1182.     pop    eax        ; udl
  1183.     div    ecx
  1184.     push    edx        ; remainder
  1185.     push    eax        ; quotient
  1186.     next            ; -- u2 u3
  1187.  
  1188.     fnamemanque    <M*>    ; n1 n2 -- d
  1189. fw_MSTAR:            ; CORE
  1190.     docode
  1191.     mov    eax,cell[esp]    ; n1
  1192.     imul    DWORD PTR [esp]    ; n1*n2
  1193.     mov    cell[esp],eax    ; dl
  1194.     mov    [esp],edx    ; dh
  1195.     next            ; -- ud
  1196.  
  1197.     nnamemanque    <UD*U>    ; ud1 u1 -- ud2
  1198. fw_UDSTARU:            ; not in standard
  1199.     docode
  1200.     pop    ecx        ; u1
  1201.     pop    eax        ; ud1h
  1202.     mul    ecx        ; produce extended ud2h
  1203.     mov    edx,ecx        ; discard upper dword of ud2he, move multiplier into edx
  1204.     mov    ecx,eax        ; save lower portion of ud2he in ecx
  1205.     pop    eax        ; ud1l
  1206.     mul    edx        ; ud2l in eax
  1207.     push    eax        ; return ud2l
  1208.     add    edx,ecx        ; form ud2h
  1209.     push    edx        ; return ud2h
  1210.     next            ; -- ud2
  1211.  
  1212. ;--( Bit Operators )
  1213.  
  1214.     fname    <TRUE>        ; -- flag
  1215.     ctok    DOCONST        ; CORE EXT
  1216.     dd    TRUE
  1217.  
  1218.     fname    <FALSE>        ; -- flag
  1219.     ctok    DOCONST        ; CORE EXT
  1220.     dd    FALSE
  1221.  
  1222.     fname    <AND>        ; x1 x2 -- x3
  1223.     docode            ; CORE
  1224.     pop    eax
  1225.     and    [esp],eax
  1226.     next
  1227.  
  1228.     fname    <OR>        ; x1 x2 -- x3
  1229.     docode            ; CORE
  1230.     pop    eax
  1231.     or    [esp],eax
  1232.     next
  1233.  
  1234.     fname    <XOR>        ; x1 x2 -- x3
  1235.     docode            ; CORE
  1236.     pop    eax
  1237.     xor    [esp],eax
  1238.     next
  1239.  
  1240.     fname    <INVERT>    ; x1 -- x2
  1241.     docode            ; CORE
  1242.     mov    eax,[esp]
  1243.     not    eax
  1244.     mov    [esp],eax
  1245.     next
  1246.  
  1247.     fnamemanque    <2*>    ; x1 -- x2
  1248. fw_TWO_STAR:            ; CORE
  1249.     docode
  1250.     mov    eax,[esp]
  1251.     shl    eax,1
  1252.     mov    [esp],eax
  1253.     next
  1254.  
  1255.     fnamemanque    <2/>    ; x1 -- x2
  1256. fw_TWO_SLASH:            ; CORE
  1257.     docode
  1258.     mov    eax,[esp]
  1259.     sar    eax,1
  1260.     mov    [esp],eax
  1261.     next
  1262.  
  1263.     fname    <LSHIFT>    ; x1 u -- x2
  1264.     docode            ; CORE
  1265.     pop    ecx
  1266.     mov    eax,[esp]
  1267.     shl    eax,cl
  1268.     mov    [esp],eax
  1269.     next
  1270.  
  1271.     fname    <RSHIFT>    ; x1 u -- x2
  1272.     docode            ; CORE
  1273.     pop    ecx
  1274.     mov    eax,[esp]
  1275.     shr    eax,cl
  1276.     mov    [esp],eax
  1277.     next
  1278.  
  1279. ;--( Characters )
  1280.  
  1281.     fname    <BL>        ; -- char
  1282.     ctok    DOCONST        ; CORE
  1283.     dd    20H
  1284.  
  1285.     fname    <CHAR>        ; -- char
  1286.     ctok    NEST        ; CORE
  1287.     ctok    BL
  1288.     ctok    WORD
  1289.     ctok    CHAR_PLUS
  1290.     ctok    C_FETCH
  1291.     ctok    UNNEST
  1292.  
  1293.     finamemanque    <[CHAR]>    ; --    Execution: -- char
  1294. fw_BRACHETCHAR:
  1295.     ctok    NEST            ; CORE
  1296.     ctok    CHAR
  1297.     ctok    LITERAL
  1298.     ctok    UNNEST
  1299.  
  1300.     fname    <SPACE>        ; --
  1301.     ctok    NEST        ; CORE
  1302.     ctok    BL
  1303.     ctok    EMIT
  1304.     ctok    UNNEST
  1305.  
  1306.     fname    <SPACES>    ; n --
  1307.     ctok    NEST        ; CORE
  1308.     literal    0
  1309.     ctok    MAX
  1310.     literal    0
  1311.     compqdo    spaces1
  1312. spaces0:
  1313.     ctok    SPACE
  1314.     comploop    spaces0
  1315. spaces1:
  1316.     ctok    UNNEST
  1317.  
  1318.     fnamemanque    <CHAR+>    ; c-addr1 -- c-addr2
  1319. fw_CHAR_PLUS:            ; CORE
  1320.     docode
  1321.     add    DWORD PTR [esp],tchar
  1322.     next
  1323.  
  1324.     fname    <CHARS>        ; n1 -- n2
  1325.     ctok    NEST        ; CORE
  1326.     literal    tchar
  1327.     ctok    STAR
  1328.     ctok    UNNEST
  1329.  
  1330.     fname    <FILL>        ; c-addr u char --
  1331.     docode            ; CORE
  1332.     pop    eax        ; char
  1333.     pop    ecx        ; count
  1334.     pop    edx        ; dest
  1335.     jecxz    fill_done    ; zero count? we're done before we start
  1336.     add    edx,dp        ; abs addr
  1337.     push    ds
  1338.     pop    es        ; same seg, this is default, but user might have changed it in a CODE word
  1339.     push    edi        ; save edi
  1340.     push    edx
  1341.     pop    edi        ; load destination
  1342.     rep    stosw        ; store char
  1343.     pop     edi        ; restore edi
  1344. fill_done:
  1345.     next
  1346.  
  1347. ;--( Strings )
  1348.  
  1349.     fnamemanque    </STRING>    ; c-addr1 u1 n -- c-addr2 u2
  1350. fw_SLSTRING:
  1351.     ctok    NEST
  1352.     ctok    ROT            ; -- u1 n c-a1
  1353.     ctok    OVER            ; -- u1 n c-a1 n
  1354.     ctok    CHARS            ; -- u1 n c-a1 nbytes
  1355.     ctok    PLUS            ; -- u1 n c-a2
  1356.     ctok    NEGROT            ; -- c-a2 u1 n
  1357.     ctok    MINUS            ; -- c-a2 u2
  1358.     ctok    UNNEST
  1359.  
  1360.     fname    <CMOVE>        ; c-addr1 c-addr2 u --
  1361.     ctok    NEST        ; STRING
  1362.     ctok    QDUP        ; -- c-addr1 c-addr2 [ u u | 0 ]
  1363.     ctok    ZEROEQ
  1364.     compif    cmove1
  1365.     ctok    TWO_DROP        ; --
  1366.     ctok    EXIT
  1367. cmove1:    literal    0
  1368.     compdo    cmove3
  1369. cmove2:    ctok    OVER        ; -- c-addr1 c-addr2 c-addr1
  1370.     ctok    C_FETCH        ; -- c-addr1 c-addr2 char
  1371.     ctok    OVER        ; -- c-addr1 c-addr2 char c-addr2
  1372.     ctok    C_STORE        ; -- c-addr1 c-addr2
  1373.     ctok    CHAR_PLUS    ; -- c-addr1 c-addr2'
  1374.     ctok    SWAP
  1375.     ctok    CHAR_PLUS    ; --  c-addr2' c-addr1'
  1376.     ctok    SWAP        ; -- c-addr1' c-addr2'
  1377.     comploop    cmove2
  1378. cmove3:    ctok    TWO_DROP
  1379.     ctok    UNNEST        ; --
  1380.  
  1381. ; Can't use our name header macros with this one!
  1382.     linkme    flinkptr
  1383.     countcell    6
  1384.     db    'C',0,'M',0,'O',0,'V',0,'E',0,'>',0        ; c-addr1 c-addr2 u --
  1385.     align    4            ; STRING
  1386. fw_CMOVER:
  1387.     ctok    NEST
  1388.     ctok    QDUP        ; -- c-addr1 c-addr2 [ u u | 0 ]
  1389.     ctok    ZEROEQ
  1390.     compif    cmover1
  1391.     ctok    TWO_DROP    ; --
  1392.     ctok    EXIT
  1393. cmover1:
  1394.     ctok    DUP        ; -- c-addr1 c-addr2  u u
  1395.     ctok    TO_R        ; -- c-addr1 c-addr2  u            R: -- u
  1396.     ctok    CHARS        ; -- c-addr1 c-addr2  u'         R: -- u
  1397.     ctok    TUCK        ; -- c-addr1 u' c-addr2 u'         R: -- u
  1398.     ctok    PLUS        ; -- c-addr1 u' c-addr2'         R: -- u
  1399.     ctok    TO_R        ; -- c-addr1 u'                 R: -- u c-addr2'
  1400.     ctok    PLUS        ; -- c-addr1'                 R: -- u c-addr2'
  1401.     ctok    R_FROM
  1402.     ctok    R_FROM        ; -- c-addr1' c-addr2' u
  1403.     literal    0
  1404.     compdo    cmover3
  1405. cmover2:
  1406.     literal    tchar        ; -- c-addr1' c-addr2' n
  1407.     ctok    MINUS        ; -- c-addr1' c-addr2''
  1408.     ctok    SWAP
  1409.     literal    tchar
  1410.     ctok    MINUS        ; -- c-addr2'' c-addr1''
  1411.     ctok    SWAP        ; -- c-addr1'' c-addr2''
  1412.     ctok    OVER        ; -- c-addr1'' c-addr2'' c-addr1''
  1413.     ctok    C_FETCH        ; -- c-addr1'' c-addr2'' char
  1414.     ctok    OVER        ; -- c-addr1'' c-addr2'' char c-addr2''
  1415.     ctok    C_STORE        ; -- c-addr1'' c-addr2''
  1416.     comploop    cmover2
  1417. cmover3:
  1418.     ctok    TWO_DROP        ; --
  1419.     ctok    UNNEST
  1420.  
  1421.     fname    <COUNT>        ; c-addr1 -- c-addr2 u
  1422.     docode
  1423.     mov    eax,[esp]
  1424.     xor    edx,edx
  1425.     mov    dx,[eax][dp]
  1426.     add    eax,tchar
  1427.     mov    [esp],eax
  1428.     push    edx
  1429.     next
  1430.  
  1431.     fname    <COMPARE>    ; c-addr1 u1 c-addr2 u2 -- n
  1432.     docode            ; STRING
  1433.     pop    ecx            ; u2
  1434.     pop    edx            ; c-addr2
  1435.     add    edx,dp            ; convert to abs addr
  1436.     pop    eax            ; u1
  1437.     cmp    ecx,eax            ; counts equal?
  1438.     je    compare_e        ; yes, continue further on
  1439.     jl    compare_u1        ; if u2 (in ecx) is lesser, continue further on
  1440.     mov    ecx,eax            ; u2 > u1
  1441.     mov    eax,[esp]        ; c-addr1
  1442.     add    eax,dp            ; convert to abs addr
  1443.     push    esi            ; preserve
  1444.     push    edi            ; preserve
  1445.     push    ds            ;
  1446.     pop    es            ; set ES, this is probably redundant in view of system requirements
  1447.     mov    esi,eax            ; c-addr1
  1448.     mov    edi,edx            ; c-addr2
  1449.     cld                ; direction upwards
  1450.     repe    cmpsw            ; unicode is 2-byte chars
  1451.     je    compare_neg1        ; all matched, u2 > u1
  1452.     mov    ax,[esi]
  1453.     cmp    ax,[edi]        ; compare non-match c-addr1 char to c-addr2 char
  1454.     jl    compare_neg1        ; c-addr1 char is less
  1455.     jmp    SHORT compare_1        ; c-addr2 char is less
  1456. compare_u1:                ; u1 > u2
  1457.     mov    eax,[esp]        ; c-addr1
  1458.     add    eax,dp            ; convert to abs addr
  1459.     push    esi            ; preserve
  1460.     push    edi            ; preserve
  1461.     push    ds            ;
  1462.     pop    es            ; set ES, this is probably redundant in view of system requirements
  1463.     mov    esi,eax            ; c-addr1
  1464.     mov    edi,edx            ; c-addr2
  1465.     cld                ; direction upwards
  1466.     repe    cmpsw            ; unicode is 2-byte chars
  1467.     je    compare_1        ; all matched, u1 > u2
  1468.     mov    ax,[esi]
  1469.     cmp    ax,[edi]        ; compare non-match c-addr1 char to c-addr2 char
  1470.     jl    compare_neg1        ; c-addr1 char is less
  1471.     jmp    SHORT compare_1        ; c-addr2 char is less
  1472. compare_e:                ; u1 = u2
  1473.     mov    eax,[esp]        ; c-addr1
  1474.     add    eax,dp            ; convert to abs addr
  1475.     push    esi            ; preserve
  1476.     push    edi            ; preserve
  1477.     push    ds            ;
  1478.     pop    es            ; set ES, this is probably redundant in view of system requirements
  1479.     mov    esi,eax            ; c-addr1
  1480.     mov    edi,edx            ; c-addr2
  1481.     cld                ; direction upwards
  1482.     repe    cmpsw            ; unicode is 2-byte chars
  1483.     je    compare_0        ; all matched
  1484.     mov    ax,[esi-2]        ; since we're pointing one past the unmatching char
  1485.     cmp    ax,[edi-2]        ; compare non-match c-addr1 char to c-addr2 char
  1486.     jl    compare_neg1        ; c-addr1 char is less
  1487.     jmp    SHORT compare_1        ; c-addr2 char is less
  1488. compare_0:
  1489.     xor    eax,eax
  1490.     mov    ((2*cell))[esp],eax        ; strings are equal and u1 = u2
  1491.     jmp    SHORT compare_done
  1492. compare_1:
  1493.     mov    eax,1
  1494.     mov    ((2*cell))[esp],eax        ; char at first non-match in c-addr1 .gt. corresponding in c-addr2
  1495.     jmp    SHORT compare_done    ; or strings equal, and u1 > u2
  1496. compare_neg1:
  1497.     mov    eax,-1
  1498.     mov    ((2*cell))[esp],eax        ; char at first non-match in c-addr1 .lt. corresponding in c-addr2
  1499.     jmp    SHORT compare_done    ; or strings equal, and u1 < u2
  1500. compare_done:
  1501.     pop    edi
  1502.     pop    esi
  1503.     next
  1504.  
  1505.     nname    <PLACE>        ; c-addr1 u c-addr2
  1506.     ctok    NEST        ; Not in Standard
  1507.     ctok    TWO_DUP        ; c-addr1 u c-addr2 u c-addr2
  1508.     ctok    C_STORE        ; c-addr1 u c-addr2
  1509.     ctok    CHAR_PLUS    ; c-addr1 u c-addr2'
  1510.     ctok    SWAP        ; c-addr1 c-addr2' u
  1511.     ctok    CHARS        ; c-addr1 c-addr2' u'
  1512.     ctok    MOVE        ; --
  1513.     ctok    UNNEST
  1514.  
  1515.     nname    <SKIP>        ; ( c-addr1 u1 char --- c-addr2 u2)
  1516.     docode            ; Not in standard, skip to first non-match
  1517.     pop    eax        ; -- c-addr u1
  1518.     pop    ecx        ; -- c-addr1        u count to iteration register
  1519.     pop    edx        ; --            address of start of string
  1520.     add    edx,dp        ; --            add offset to base of data region, forming absolute address
  1521.     push    edi        ; -- edi            preserve edi
  1522.     push    ds        ; -- edi ds
  1523.     pop    es        ; -- edi            load es from ds
  1524.     push    edx        ; -- edi abs-addr1
  1525.     pop    edi        ; -- edi            load edi
  1526.     cld            ; ascending search
  1527.     repe    scasw        ; search for non-match
  1528.     je    skip_fail    ; zero is set if no non-match was found
  1529.     pop    eax        ; --            saved di
  1530.     push    edi        ; -- abs-addr2        address after end of string, abs
  1531.     pop    edx        ; --            get it back
  1532.     sub    edx,tchar    ; --            move it back to point to non-match char
  1533.     sub    edx,dp        ; --            convert back to data-relative address
  1534.     push    edx        ; -- c-addr2        return it
  1535.     inc    ecx        ; -- c-addr2        back count up to match point
  1536.     push    ecx        ; -- c-addr2 u2        return count of remainder of string
  1537.     push    eax        ; -- c-addr2 u2 di
  1538.     pop    edi        ; -- c-addr2 u2        restore edi
  1539.     next
  1540. skip_fail:
  1541.     pop    eax        ; saved edi
  1542.     push    edi        ; address after end of string, abs
  1543.     pop    edx        ; get it back
  1544.     sub    edx,dp        ; convert back to data-relative address
  1545.     push    edx        ; return it
  1546.     push    ecx        ; return zero which will be in ecx in this branch
  1547.     push    eax        ; that ol' saved di
  1548.     pop    edi        ; restore, -- c-addr2 u2
  1549.     next
  1550.  
  1551.     nname    <SCAN>        ; ( c-addr1 u1 char --- c-addr2 u2)
  1552.     docode            ; Not in Standard, point to head of substring c-addr2 u2 where char first found
  1553.     pop    eax        ; char
  1554.     pop    ecx        ; count to iteration register
  1555.     pop    edx        ; address of start of string
  1556.     add    edx,dp        ; add offset to base of data seg
  1557.     push    edi        ; save edi
  1558.     push    ds
  1559.     pop    es        ; load es from ds
  1560.     push    edx
  1561.     pop    edi        ; load edi
  1562.     cld            ; ascending search
  1563.     repne    scasw        ; search for match
  1564.     jne    scan_fail    ; zero is set if char was ever found
  1565.     pop    eax        ; saved edi
  1566.     push    edi        ; address after end of string, abs
  1567.     pop    edx        ; get it back
  1568.     sub    edx,tchar    ; move it back to match char
  1569.     sub    edx,dp        ; convert back to data-relative address
  1570.     push    edx        ; return it
  1571.     inc    ecx        ; back count up to match point
  1572.     push    ecx        ; return count of remainder of string
  1573.     push    eax        ; that ol' saved edi
  1574.     pop    edi        ; restore, -- c-addr2 u2
  1575.     next
  1576. scan_fail:
  1577.     pop    eax        ; saved edi
  1578.     push    edi        ; address after end of string, abs
  1579.     pop    edx        ; get it back
  1580.     sub    edx,dp        ; convert back to data-relative address
  1581.     push    edx        ; return it
  1582.     push    ecx        ; return zero which will be in ecx in this branch
  1583.     push    eax        ; that ol' saved edi
  1584.     pop    edi        ; restore, -- c-addr2 u2
  1585.     next
  1586.  
  1587.     fnamemanque    <-TRAILING>    ; c-addr1 u1 -- c-addr1 u2
  1588. fw_DASH_TRAILING:            ; STRING
  1589.     docode
  1590.     mov    ecx,[esp]    ; count
  1591.     mov    edx,cell[esp]    ; string address
  1592.     add    edx,ecx        ; do this twice to handle wide character size
  1593.     add    edx,ecx        ; point past end of string
  1594.     sub    edx,tchar    ; point to last character in string
  1595.     add    edx,dp        ; absolute address
  1596.     mov    ax,20h        ; blank
  1597.     push    edi        ; preserve edi
  1598.     push    edx        ; end-of-string abs address
  1599.     pop    edi        ; load edi
  1600.     push    ds
  1601.     pop    es        ; same seg, probably redundant
  1602.     std            ; backwards search
  1603.     repe    scasw        ; seek non-match with char
  1604.     je    none_trailing    ; no non-blanks
  1605.     pop    edi        ; restore edi
  1606.     inc    cx        ; adjust count to point back to end of string
  1607.     mov    [esp],ecx    ; new count
  1608.     cld            ; !!!***!!! important, NEXT won't work unless direction flag set this way
  1609.     next
  1610. none_trailing:                ; no non-blanks at all
  1611.     pop    edi            ; restore edi
  1612.     mov    DWORD PTR [esp],FALSE    ; zero count
  1613.     cld            ; !!!***!!! important, NEXT won't work unless direction flag set this way
  1614.     next
  1615.  
  1616.     finame    <SLITERAL>    ; c-addr1 u    Execution: -- c-addr2 u
  1617.     ctok    NEST        ; STRING
  1618.     ctok    STATEABORT
  1619.     ctok    ALIGN
  1620.     ctok    DUP        ; -- c-addr1 u u
  1621.     ctok    HERE        ; -- c-addr1 u u here
  1622.     ctok    TWO_SWAP    ; -- u here c-addr1 u
  1623.     ctok    HERE        ; -- u here c-addr1 u here
  1624.     ctok    PLACE        ; -- u here
  1625.     ctok    DOLIT
  1626.     ctok    DOSQUOTE    ; -- u here xt
  1627.     ctok    COMPCOMMA
  1628.     ctok    COMPCOMMA    ; -- u
  1629.     ctok    ONE_PLUS    ; -- u'        account for count character
  1630.     ctok    CHARS        ; -- chars
  1631.     ctok    ALLOT        ; --
  1632.     ctok    UNNEST
  1633.  
  1634. ; Can't use our name header macros with this one!
  1635.     linkme    flinkptr
  1636.     countcell    <2 or immedMask>
  1637.     db    'S',0,'"',0        ; Interp: "ccc<"> -- c-addr u    Compile: "ccc<"> -- Execute: c-addr u
  1638.     align    4            ; FILE
  1639. fw_S_QUOTE:
  1640.     ctok    NEST
  1641.     charlit    '"'            ; -- char
  1642.     ctok    PARSE            ; -- c-addr u
  1643.     ctok    STATE            ; -- c-addr u a-addr
  1644.     ctok    FETCH            ; -- c-addr u flag
  1645.     compif    s_quote1        ; are we compiling?
  1646.     ctok    ALIGN            ; for good luck -- maybe this should be removed
  1647.     ctok    HERE            ; -- c-addr1 u c-addr2
  1648.     ctok    DUP            ; -- c-addr1 u c-addr2 c-addr2
  1649.     ctok    TO_R            ; -- c-addr1 u c-addr2        R: -- c-addr2
  1650.     ctok    OVER            ; -- c-addr1 u c-addr2 u    R: -- c-addr2
  1651.     ctok    ONE_PLUS        ; -- c-addr1 u c-addr2 u'    R: -- c-addr2
  1652.     ctok    CHARS            ; -- c-addr1 u c-addr2 chars    R: -- c-addr2
  1653.     ctok    ALLOT            ; -- c-addr1 u c-addr2        R: -- c-addr2
  1654.     ctok    PLACE            ; --                 R: -- c-addr2
  1655.     literal    0
  1656.     ctok    CCOMMA            ; --    null pad
  1657.     ctok    DOLIT
  1658.     ctok    DOSQUOTE        ; -- xt                R: -- c-addr2
  1659.     ctok    COMPCOMMA        ; --                 R: -- c-addr2
  1660.     ctok    R_FROM            ; -- c-addr2            R: --
  1661.     ctok    COMPCOMMA        ; --
  1662.     ctok    EXIT
  1663. s_quote1:
  1664.     literal    stringBuffer        ; -- c-addr1 u c-addr2
  1665.     ctok    PLACE            ; --
  1666.     literal    stringBuffer        ; -- c-addr2
  1667.     ctok    COUNT            ; -- c-addr2 u
  1668.     ctok    TWO_DUP
  1669.     ctok    CHARS
  1670.     ctok    PLUS
  1671.     literal    0
  1672.     ctok    SWAP
  1673.     ctok    C_STORE            ; append null terminator
  1674.     ctok    UNNEST
  1675.  
  1676. ; Can't use our name header macros with this one!
  1677.     linkme    flinkptr
  1678.     countcell    <2 or immedMask>
  1679.     db    '.',0,'"',0        ; Interp: -- c-addr u    Compile --
  1680.     align    4            ; CORE
  1681. fw_DOT_QUOTE:
  1682.     ctok    NEST
  1683.     ctok    STATEABORT
  1684.     ctok    DP
  1685.     ctok    FETCH            ; -- dictionary-pointer
  1686.     ctok    S_QUOTE            ; -- dp        S" has stored string and embedded execution engine
  1687.     ctok    DOLIT
  1688.     ctok    DODOTQUOTE
  1689.     ctok    SWAP            ; -- xt dp
  1690.     ctok    CODETODATA
  1691.     ctok    STORE            ; --        overwrite S" exe engine with ." exe engine
  1692.     ctok    UNNEST
  1693.  
  1694.     fname    <PAD>            ; -- c-addr
  1695.     ctok    DOCONST            ; CORE EXT
  1696.     dd    tickpad
  1697.  
  1698. ;--( Number Conversion )
  1699.  
  1700.     fname    <BASE>        ; a-addr
  1701.     ctok    DOCONST        ; CORE
  1702.     dd    var_base
  1703.  
  1704.     fname    <DECIMAL>    ; --
  1705.     ctok    NEST        ; CORE
  1706.     literal    10
  1707.     ctok    BASE
  1708.     ctok    STORE
  1709.     ctok    UNNEST
  1710.  
  1711.     fname    <HEX>        ; --
  1712.     ctok    NEST        ; CORE
  1713.     literal    16
  1714.     ctok    BASE
  1715.     ctok    STORE
  1716.     ctok    UNNEST
  1717.  
  1718.     fname    <HLD>        ; a-addr
  1719.     ctok    DOCONST        ; Implementation detail
  1720.     dd    var_hld
  1721.  
  1722.     fname    <HOLD>        ; char --
  1723.     ctok    NEST        ; CORE
  1724.     literal    -1
  1725.     ctok    CHARS
  1726.     ctok    HLD
  1727.     ctok    PL_STORE    ; predecrement offset pointer which was set by <#
  1728.     ctok    HLD
  1729.     ctok    FETCH
  1730.     ctok    C_STORE        ; store character in numeric format buffer
  1731.     ctok    UNNEST
  1732.  
  1733. ; Is char a digit in base n?
  1734.     nname    <DIGIT>        ; char n1 -- n2 true | char false
  1735.     docode            ; Not in Standard
  1736.     pop    edx        ; base
  1737.     pop    eax        ; char
  1738.     mov    ecx,eax        ; save copy of char
  1739.     sub    ax,'0'        ; is char >= '0'
  1740.     jb    not_digit    ; if not, jump not_digit
  1741.     cmp    ax,9        ; is char <= 9
  1742.     jbe    digit1        ; yes, jump to digit_1
  1743.     cmp    ax,'A'-'0'    ; no, see if it's an alpha number
  1744.     jb    not_digit    ; it ain't, jump away
  1745.     sub    ax,'A'-'0'-10    ; it is, subtract offset of that portion of char set to make correct digit
  1746. digit1:    cmp    ax,dx        ; now compare resultant number to base
  1747.     jnb    not_digit    ; it ain't a digit if it ain't below the value of the base
  1748.     push    eax        ; it is a digit, push
  1749.     push    TRUE        ; TRUE for success
  1750.     next
  1751. not_digit:
  1752.     push    ecx        ; char
  1753.     xor    eax,eax        ; false, failure
  1754.     push    eax
  1755.     next
  1756.  
  1757.     nname    <DPL>        ; -- a-addr
  1758.     ctok    DOCONST        ; Not in Standard
  1759.     dd    var_dpl
  1760.  
  1761.     nname    <NUMBER>    ; c-addr1 u1 -- d TRUE | x x FALSE
  1762.     ctok    NEST        ; Not in Standard
  1763.     ctok    TRUE
  1764.     ctok    DPL
  1765.     ctok    STORE        ; indicate no dot in number input as default
  1766.     ctok    OVER        ; -- c-a1 u1 c-a1
  1767.     ctok    C_FETCH        ; -- c-a1 u1 char
  1768.     charlit    '-'        ; -- c-a1 u1 char1 char2
  1769.     ctok    EQUAL        ; -- c-a1 u1 flag
  1770.     ctok    DUP        ; -- c-a1 u1 flag flag
  1771.     ctok    TO_R        ; -- c-a1 u1 flag flag            R: -- flag    save negative flag
  1772.     compif    number1        ; was there a prepended negative sign?
  1773.     ctok    ONE_MINUS    ; -- c-a1 u1'                R: -- flag    yes, dec count
  1774.     ctok    SWAP
  1775.     ctok    CHAR_PLUS    ; -- u1' c-a1'                R: -- flag    advance address
  1776.     ctok    SWAP        ; -- c-a1' u1'                R: -- flag
  1777. number1:
  1778.     ctok    FALSE
  1779.     ctok    FALSE        ; -- c-a1' u1' ud            R: -- flag
  1780.     ctok    TWO_SWAP    ; -- ud c-a1' u1'            R: -- flag
  1781. number2:
  1782.     ctok    TO_NUMBER    ; -- ud c-a2 u2                R: -- flag
  1783.     ctok    QDUP        ; -- ud c-a2 [ u2 u2 | 0 ]        R: -- flag
  1784.     compif    number_success    ; did number conversion complete leave non-zero count of chars left?
  1785.     ctok    OVER        ; -- ud c-a2 u2 c-a2            R: -- flag
  1786.     ctok    C_FETCH        ; -- ud c-a2 u2 char            R: -- flag
  1787.     charlit    '.'        ; -- ud c-a2 u2 char1 char2        R: -- flag
  1788.     ctok    EQUAL        ; -- ud c-a2 u2 flag            R: -- flag
  1789.     compif    number_fail    ; was the character which stopped the conversion a "dot"?
  1790.     ctok    DUP        ; -- ud c-a2 u2 u2        R: -- flag
  1791.     ctok    ONE_MINUS    ; -- ud c-a2 u2 u2'        R: -- flag
  1792.     ctok    DPL        ; -- ud c-a2 u2 u2' a-addr    R: -- flag    ; right-justified count to dot-place-marker
  1793.     ctok    STORE        ; -- ud c-a2 u2            R: -- flag
  1794.     ctok    ONE_MINUS    ; -- ud c-a2 u2'        R: -- flag
  1795.     ctok    SWAP        ; -- ud u2' c-a2        R: -- flag
  1796.     ctok    CHAR_PLUS    ; -- ud u2' c-a2'        R: -- flag
  1797.     ctok    SWAP        ; -- ud c-a2' u2'        R: -- flag
  1798.     ctok    DUP        ; -- ud c-a2' u2'        R: -- flag
  1799.     ctok    DOUNTILNOT    ; more chars? try it some more! This allows multiple dots in a number ... sounds ok
  1800.     dd    number2        ; otherwise, we're done if parsing the "dot" exhausted the string
  1801.     ctok    DROP        ; -- ud c-a2'            R: -- flag
  1802.     compelse    number_success
  1803. number_fail:            ; -- ud c-a u            R: -- flag
  1804.     ctok    TWO_DROP    ; -- ud                R: -- flag
  1805.     ctok    FALSE        ; -- ud 0            R: -- flag
  1806.     ctok    R_FROM        ; -- ud 0 flag            R: -- 
  1807.     ctok    DROP        ; -- ud 0
  1808.     ctok    EXIT        ; -- x x 0
  1809. number_success:            ; -- ud c-addr            R: -- flag
  1810.     ctok    DROP        ; -- ud                R: -- flag
  1811.     ctok    R_FROM        ; -- ud flag            R: --
  1812.     compif    number_done    ; did we mark this negative?
  1813.     ctok    DNEGATE        ; -- d
  1814. number_done:
  1815.     ctok    TRUE        ; -- d true
  1816.     ctok    UNNEST
  1817.  
  1818. ; Can't use our name header macros with this one!
  1819.     linkme    flinkptr
  1820.     countcell    7
  1821.     db    '>',0,'N',0,'U',0,'M',0,'B',0,'E',0,'R',0    ; ud1 c-addr1 u1 -- ud2 c-addr2 u2
  1822. fw_TO_NUMBER:
  1823.     ctok    NEST
  1824. tonum1:    ctok    DUP        ; BEGIN -- ud1 c-addr1 u1 u1
  1825.     compif    tonum4        ; WHILE
  1826.     ctok    SWAP        ; -- ud1 u1 c-addr1
  1827.     ctok    COUNT        ; -- ud1 u1 c-addr char
  1828.     ctok    BASE        ; -- ud1 u1 c-addr char a-addr
  1829.     ctok    FETCH        ; -- ud1 u1 c-addr char n
  1830.     ctok    DIGIT        ; -- ud1 u1 c-addr n flag
  1831.     compif    tonum2        ; if it's a digit
  1832.     ctok    TO_R        ; -- ud1 u1 c-addr            R: -- n
  1833.     ctok    TWO_SWAP    ; -- u1 c-addr ud1            R: -- n
  1834.     ctok    BASE
  1835.     ctok    FETCH        ; -- u1 c-addr ud1 n            R: -- n
  1836.     ctok    UDSTARU        ; -- u1 c-addr ud            R: -- n
  1837.     ctok    R_FROM
  1838.     literal    0        ; -- u1 c-addr ud "udx"            R: --
  1839.     ctok    D_PLUS        ; -- u1 c-addr ud'
  1840.     ctok    TWO_SWAP    ; -- ud' u1 c-addr
  1841.     ctok    SWAP        ; -- ud2 c-addr u1
  1842.     compelse    tonum3    ; ELSE
  1843. tonum2:    ctok    DROP        ; -- ud2 u2 c-addr
  1844.     literal    tchar
  1845.     ctok    MINUS        ; -- ud2 u2 c-addr2
  1846.     ctok    SWAP        ; -- ud2 c-addr2 u2
  1847.     ctok    EXIT        ; THEN
  1848. tonum3:    ctok    ONE_MINUS    ; -- ud c-addr u
  1849.     compelse    tonum1    ; REPEAT
  1850. tonum4:    ctok    UNNEST        ; -- ud2 c-addr2 u2
  1851.  
  1852. ; Can't use our name header macros with this one!
  1853.     linkme    flinkptr
  1854.     countcell    2
  1855.     db    '<',0,'#',0    ; --
  1856.     align    4            ; CORE
  1857. fw_LSHARP:
  1858.     ctok    NEST
  1859.     literal    ticknumend
  1860.     ctok    HLD
  1861.     ctok    STORE        ; set up pointer to numeric output string format buffer
  1862.     ctok    UNNEST
  1863.  
  1864.     fnamemanque    <#>    ; ud1 -- ud2
  1865. fw_SHARP:
  1866.     ctok    NEST
  1867.     ctok    BASE
  1868.     ctok    FETCH
  1869.     ctok    DUMSLMOD    ; -- r ud'
  1870.     ctok    ROT
  1871.     ctok    DUP
  1872.     literal    10
  1873.     ctok    LESS        ; -- ud' r flag        ; is this within the numeric Unicode chars?
  1874.     compif    sharp1
  1875.     ctok    DOLIT
  1876.     db    '0',0,0,0    ; -- ud' r char        ; yes, we'll need to add its number to the char '0'
  1877.     compelse sharp2
  1878. sharp1:    literal    'A'-10        ; -- ud' r char        ; no we'll need to add its number to an offset from 'A'
  1879. sharp2:    ctok    PLUS        ; -- ud' char'
  1880.     ctok    HOLD        ; -- ud'        ; store char
  1881.     ctok    UNNEST
  1882.  
  1883.     fnamemanque    <#S>    ; ud1 -- ud2
  1884. fw_SHARPS:
  1885.     ctok    NEST
  1886. sharps:
  1887.     ctok    SHARP        ; -- ud'        loop converting chars
  1888.     ctok    TWO_DUP        ; -- ud' ud'
  1889.     ctok    OR        ; -- ud' flag
  1890.     ctok    DOUNTILNOT    ; -- ud'        loop until it's 0.0
  1891.     dd    sharps
  1892.     ctok    UNNEST
  1893.     
  1894. ; Can't use our name header macros with this one!
  1895.     linkme    flinkptr
  1896.     countcell    2
  1897.     db    '#',0,'>',0    ; ud -- c-addr u
  1898.     align    4        ; CORE
  1899. fw_SHARPR:
  1900.     ctok    NEST
  1901.     ctok    TWO_DROP    ; --            discard what's left of double which was to be formatted
  1902.     ctok    HLD        
  1903.     ctok    FETCH        ; -- c-addr
  1904.     literal    ticknumend    ; -- c-addr1 c-addr2
  1905.     ctok    OVER        ; -- c-addr1 c-addr2
  1906.     ctok    MINUS        ; -- c-addr1 n
  1907.     literal    1
  1908.     ctok    CHARS        ; -- c-addr1 n sizeofchar    address diff has to be divided by char size
  1909.     ctok    SLASH        ; -- c-addr u
  1910.     ctok    UNNEST
  1911.  
  1912. ;--( I/O )
  1913.  
  1914.     fname    <CR>    ; --
  1915.     ctok    NEST    ; CORE
  1916.     literal    0DH
  1917.     ctok    EMIT
  1918.     literal    0AH
  1919.     ctok    EMIT
  1920.     ctok    UNNEST
  1921.  
  1922.     fname    <SIGN>    ; n --
  1923.     ctok    NEST    ; CORE
  1924.     ctok    ZEROLT
  1925.     compif    sign1
  1926.     charlit    '-'
  1927.     ctok    HOLD    
  1928. sign1:    ctok    UNNEST
  1929.  
  1930.     fnamemanque    <.>    ; n --
  1931. fw_DOT:    ctok    NEST        ; CORE
  1932.     ctok    PDOT
  1933.     ctok    TYPE        ; --
  1934.     ctok    BL
  1935.     ctok    EMIT
  1936.     ctok    UNNEST
  1937.  
  1938.     fnamemanque    <.R>    ; n1 n2 --
  1939. fw_DOT_R:
  1940.     ctok    NEST        ; CORE EXT
  1941.     ctok    SWAP        ; -- n2 n1            
  1942.     ctok    PDOT        ; -- n2 c-addr u
  1943.     ctok    ROT        ; -- c-addr u n2
  1944.     ctok    OVER        ; -- c-addr u n2 u
  1945.     ctok    MINUS        ; -- c-addr u1 u2
  1946.     literal    0
  1947.     ctok    MAX        ; -- c-addr u1 u2'
  1948.     ctok    SPACES        ; -- c-addr u
  1949.     ctok    TYPE        ; --
  1950.     ctok    UNNEST
  1951.  
  1952.     znamemanque    <(.)>    ; n -- c-addr u
  1953. fw_PDOT:
  1954.     ctok    NEST
  1955.     ctok    DUP        ; -- n n
  1956.     ctok    ABS        ; -- n _n_
  1957.     ctok    S_TO_D        ; -- n d
  1958.     ctok    LSHARP        ; -- n d
  1959.     ctok    SHARPS        ; -- n d'
  1960.     ctok    ROT        ; -- d' n
  1961.     ctok    SIGN        ; -- d
  1962.     ctok    SHARPR        ; -- c-addr u
  1963.     ctok    UNNEST
  1964.  
  1965.     fnamemanque    <D.>    ; d --
  1966. fw_D_DOT:
  1967.     ctok    NEST        ; CORE
  1968.     ctok    TUCK        ; -- dh d
  1969.     ctok    DABS        ; -- dh _d_
  1970.     ctok    LSHARP        ; -- dh _d_
  1971.     ctok    SHARPS        ; -- dh d'
  1972.     ctok    ROT        ; -- d' dh
  1973.     ctok    SIGN        ; -- d'
  1974.     ctok    SHARPR        ; -- c-addr u
  1975.     ctok    TYPE        ; --
  1976.     ctok    BL
  1977.     ctok    EMIT
  1978.     ctok    UNNEST
  1979.  
  1980.     fnamemanque    <U.>    ; u --
  1981. fw_U_DOT:            ; CORE
  1982.     ctok    NEST
  1983.     literal    0
  1984.     ctok    UD_DOT
  1985.     ctok    UNNEST
  1986.  
  1987.     nnamemanque    <UD.>    ; ud --
  1988. fw_UD_DOT:            ; Not in Standard
  1989.     ctok    NEST
  1990.     ctok    LSHARP
  1991.     ctok    SHARPS
  1992.     ctok    SHARPR
  1993.     ctok    TYPE
  1994.     ctok    BL
  1995.     ctok    EMIT
  1996.     ctok    UNNEST
  1997.  
  1998.     fnamemanque    <U.R>    ; u n --
  1999. fw_U_DOT_R:            ; Not in Standard
  2000.     ctok    NEST
  2001.     literal    0
  2002.     ctok    SWAP
  2003.     ctok    UD_DOT_R
  2004.     ctok    UNNEST
  2005.  
  2006.     nnamemanque    <UD.R>    ; ud n --
  2007. fw_UD_DOT_R:            ; Not in Standard
  2008.     ctok    NEST
  2009.     ctok    TO_R
  2010.     ctok    LSHARP
  2011.     ctok    SHARPS
  2012.     ctok    SHARPR
  2013.     ctok    R_FROM
  2014.     ctok    OVER
  2015.     ctok    MINUS
  2016.     literal    0
  2017.     ctok    MAX
  2018.     ctok    SPACES
  2019.     ctok    TYPE
  2020.     ctok    BL
  2021.     ctok    EMIT
  2022.     ctok    UNNEST
  2023.  
  2024.     fnamemanque    <.S>    ; i*x -- i*x
  2025. fw_DOT_S:            ; CORE EXT
  2026.     ctok    NEST
  2027.     ctok    DEPTH
  2028.     literal    0
  2029.     ctok    MAX
  2030.     ctok    DUP
  2031.     literal    0
  2032.     compqdo    dot_s1
  2033. dot_s0:
  2034.     ctok    DUP
  2035.     ctok    I
  2036.     ctok    MINUS
  2037.     ctok    PICK
  2038.     ctok    U_DOT
  2039.     comploop    dot_s0
  2040. dot_s1:    ctok    DROP
  2041.     ctok     UNNEST
  2042.  
  2043.     zname    <DEBDOTS>    ; i*j char -- i*j
  2044.     ctok    NEST
  2045.     ctok    EMIT
  2046.     ctok    SPACE
  2047.     ctok    DOT_S
  2048.     ctok    KEY
  2049.     ctok    DROP
  2050.     ctok    CR
  2051.     ctok    UNNEST
  2052.  
  2053.     fnamemanque    <KEY?>                ; -- flag
  2054. fw_KEY_Q:                        ; FACILITY
  2055.     docode
  2056.     mov    DWORD PTR lastError[dp],TRUE        ; No windows error code has all bits set
  2057.     mov    eax,256                    ; number of records to try for per Microsoft
  2058.     INVOKE    PeekConsoleInputW, [dp+stdIn], OFFSET FLAT:inRecArray, eax, OFFSET FLAT:numRead
  2059.     and    eax,eax                    ; "C" TRUE is success
  2060.     jne    keyq1                    ; on success, continue further on
  2061.     push    eax                    ; push failure
  2062.     jmp    doLastErr                ; on failure, return via set error code routine
  2063. keyq1:     mov    ecx,[numRead]                ; number of input records successfully peeked
  2064.     and    ecx,ecx
  2065.     je    keyq_none                ; none? fergit it!
  2066.     mov    eax,OFFSET FLAT:inRecArray
  2067. keyq2:    .IF    (WORD PTR [eax].INPUT_RECORD.EventType == KEY_EVENT) && \        ; is it a key event?
  2068.         (DWORD PTR [eax].INPUT_RECORD.Event.KeyEvent.bKeyDown != 0) && \    ; a press?
  2069.         ((WORD PTR [eax].INPUT_RECORD.Event.KeyEvent.uChar.UnicodeChar >= 1BH) || \    ; part of char set?
  2070.          (WORD PTR [eax].INPUT_RECORD.Event.KeyEvent.uChar.UnicodeChar == 0DH))
  2071.     jmp    keyq_found                ; if C-language "true", a key is down, we're done
  2072.     .ENDIF
  2073. keyq_continue:
  2074.     add    eax,SIZE INPUT_RECORD
  2075.     loop    keyq2
  2076. keyq_none:                        ; nope
  2077.     push    FALSE
  2078.     next
  2079. keyq_found:                        ; yup
  2080.     push    TRUE
  2081.     next
  2082.     
  2083.     fname    <KEY>    ; -- char
  2084.     docode        ; CORE
  2085.     xor    ecx,ecx                    ; clear character holder
  2086.     lea    eax,[dp+conMode]            ; in order to preserve con mode
  2087.     INVOKE    GetConsoleMode, [dp+stdIn], eax        ; let's find out what it is
  2088.     and    eax,eax                    ; success is "C" TRUE
  2089.     jne    key2                    ; if GetConsoleMode succeeds, continue
  2090.     mov    eax,UniNotAChar                ; on failure, push invalid char
  2091.     push    eax
  2092.     jmp    doLastErr                ; return to NEXT via doLastErr
  2093. key2:    INVOKE    SetConsoleMode, [dp+stdIn], 0        ; set no echo, no line input, no window/mouse/processed
  2094.     and    eax,eax                    ; success is "C" TRUE
  2095.     jne    key3                    ; if SetConsoleMode succeeds, continue
  2096.     mov    eax,UniNotAChar                ; on failure, push invalid char
  2097.     push    eax
  2098.     jmp    doLastErr                ; return to NEXT via doLastErr
  2099. key3:    INVOKE    ReadConsoleW, [dp+stdIn], OFFSET FLAT:lastReadConW, 1, OFFSET FLAT:numRead, 0    ; get a char
  2100.     and    eax,eax                ; "C" TRUE is success
  2101.     je    key4                ; on failure, get error code
  2102.     mov    DWORD PTR lastError[dp],TRUE    ; success, return TRUE, no Windows error code has all bits set
  2103.     cmp    DWORD PTR numRead,0        ; did we get any?
  2104.     je    key3                ; loop waiting
  2105.     xor    ecx,ecx                ; clear for character
  2106.     mov    cx,WORD PTR lastReadConW    ; retrieve char, ecx ostensibly clear for now
  2107.     push    ecx                ; push to stack
  2108.     mov    eax,conMode[dp]            ; get saved console mode
  2109.     INVOKE    SetConsoleMode, [dp+stdIn], eax    ; restore previous console mode, don't worry about err here
  2110.     next    
  2111. key4:    INVOKE    GetLastError            ; on this error, don't worry about console mode
  2112.     mov    lastError[dp],eax        ; save error return
  2113.     mov    eax,UniNotAChar
  2114.     push    eax
  2115.     next
  2116.  
  2117.     fnamemanque    <EKEY?>                ; -- flag
  2118. fw_EKEY_Q:                        ; FACILITY
  2119.     docode
  2120.     mov    DWORD PTR lastError[dp],TRUE        ; No windows error code has all bits set
  2121.     mov    eax,256                    ; number of records to try for per Microsoft
  2122.     INVOKE    PeekConsoleInputW, [dp+stdIn], OFFSET FLAT:inRecArray, eax, OFFSET FLAT:numRead
  2123.     and    eax,eax                    ; "C" TRUE is success
  2124.     jne    ekeyq1                    ; on success, continue further on
  2125.     push    eax                    ; push failure
  2126.     jmp    doLastErr                ; on failure, return via set error code routine
  2127. ekeyq1:    mov    ecx,[numRead]                ; number of input records successfully peeked
  2128.     and    ecx,ecx
  2129.     je    ekeyq_none                ; none? fergit it!
  2130.     mov    eax,OFFSET FLAT:inRecArray
  2131. ekeyq2:    cmp    WORD PTR [eax].INPUT_RECORD.EventType,KEY_EVENT
  2132.                             ; loop comparing the EventType field in each struc
  2133.     jne    ekeyq_continue                ; not a KEY_EVENT, loop
  2134.     cmp    DWORD PTR [eax].INPUT_RECORD.Event.KeyEvent.bKeyDown,0    ; test if we have a key down
  2135.     jne    ekeyq_found                ; if C-language "true", a key is down, we're done
  2136. ekeyq_continue:
  2137.     add    eax,SIZE INPUT_RECORD
  2138.     loop    ekeyq2
  2139. ekeyq_none:                        ; nope
  2140.     push    FALSE
  2141.     next
  2142. ekeyq_found:                        ; yup
  2143.     push    TRUE
  2144.     next
  2145.  
  2146.     fname    <EKEY>                    ; -- u
  2147.     ctok    NEST                    ; FACILITY EXT
  2148. ekey1:    ctok    pEKEY        ; -- u flag
  2149.     compif    ekey2
  2150.     ctok    EXIT
  2151. ekey2:    ctok    DROP
  2152.     compelse    ekey1    ; loop until got one
  2153.     
  2154.     zname    <pEKEY>                    ; -- u flag
  2155.     docode
  2156.     mov    DWORD PTR lastError[dp],TRUE        ; No windows error code has all bits set
  2157.     lea    eax,[dp+conMode]            ; in order to preserve con mode
  2158.     INVOKE    GetConsoleMode, [dp+stdIn], eax        ; let's find out what it is
  2159.     and    eax,eax                    ; success is "C" TRUE
  2160.     jne    pekey_setcon                ; if GetConsoleMode succeeds, continue
  2161. pekey_setfail:
  2162.     push    eax
  2163.     push    eax                    ; -- u flag
  2164.     INVOKE    GetLastError
  2165.     mov    lastError[dp],eax        ; save error return
  2166.     mov    eax,conMode[dp]            ; get saved console mode
  2167.     INVOKE    SetConsoleMode, [dp+stdIn], eax    ; restore previous console mode, don't worry about err here
  2168.     next
  2169. pekey_setcon:
  2170.     INVOKE    SetConsoleMode, [dp+stdIn], 0        ; set no echo, no line input, no window/mouse/processed
  2171.     and    eax,eax                    ; success is "C" TRUE
  2172.     je    pekey_setfail                ; if couldn't set console mode
  2173. pkey0:    INVOKE    ReadConsoleInputW, [dp+stdIn], OFFSET FLAT:inRecArray, 1, OFFSET FLAT:numRead
  2174.     and    eax,eax                    ; "C" TRUE is success
  2175.     jne    pekey1                    ; on success, continue further on
  2176.     push    eax                    ; push failure
  2177.     push    eax                    ; -- u flag
  2178.     INVOKE    GetLastError
  2179.     mov    lastError[dp],eax        ; save error return
  2180.     mov    eax,conMode[dp]            ; get saved console mode
  2181.     INVOKE    SetConsoleMode, [dp+stdIn], eax    ; restore previous console mode, don't worry about err here
  2182.     next
  2183. pekey1:    mov    eax,OFFSET FLAT:inRecArray
  2184.     .IF    WORD PTR [eax].INPUT_RECORD.EventType != KEY_EVENT
  2185.     jmp    pekey_none            ; it ain't a key event, we don't care
  2186.     .ENDIF
  2187.     .IF    [eax].INPUT_RECORD.Event.KeyEvent.bKeyDown == 0
  2188.     jmp    pekey_none
  2189.     .ENDIF
  2190.     mov    dx,[eax].INPUT_RECORD.Event.KeyEvent.wVirtualKeyCode
  2191.     mov    cl,16
  2192.     shl    edx,cl
  2193.     mov    dx,[eax].INPUT_RECORD.Event.KeyEvent.uChar.UnicodeChar
  2194.     push    edx
  2195.     push    TRUE                    ; -- u flag
  2196.     mov    eax,conMode[dp]            ; get saved console mode
  2197.     INVOKE    SetConsoleMode, [dp+stdIn], eax    ; restore previous console mode, don't worry about err here
  2198.     next
  2199. pekey_none:
  2200.     push    FALSE
  2201.     push    FALSE                    ; -- u flag
  2202.     mov    eax,conMode[dp]            ; get saved console mode
  2203.     INVOKE    SetConsoleMode, [dp+stdIn], eax    ; restore previous console mode, don't worry about err here
  2204.     next
  2205.  
  2206.     fname    <TYPE>        ; c-addr u --
  2207.     dd    ftype
  2208. ftype:    pop    eax
  2209.     pop    edx
  2210.     lea    edx,[edx][dp]
  2211.     INVOKE    WriteConsoleW, [dp+stdOut], edx, eax, OFFSET FLAT:numWritten, 0
  2212.     jmp    SHORT    doLastErr        ; returns to NEXT via doLastErr
  2213.  
  2214.     fname    <EMIT>
  2215.     dd    emit
  2216. emit:    pop    DWORD PTR [dp+outChar]
  2217.     lea    eax,[dp+outChar]
  2218.     INVOKE    WriteConsoleW, [dp+stdOut], eax, 1, OFFSET FLAT:numWritten,0
  2219.     jmp    SHORT    doLastErr        ; returns to NEXT via doLastErr
  2220.  
  2221. ; Serve these I/O words to set our local LastError variable either TRUE for success or to return from LastError.
  2222. doLastErr:
  2223.     and    eax,eax                ; "C" TRUE is success
  2224.     je    dLE1                ; on failure, get error code
  2225.     mov    DWORD PTR lastError[dp],TRUE    ; success, return TRUE
  2226.     next                    ; No Windows error code has all bits set
  2227. dLE1:    INVOKE    GetLastError
  2228.     mov    lastError[dp],eax        ; save error return
  2229.     next
  2230.  
  2231. ; Calls factor (ACCEPT), then handles trailing CR/LF pair.
  2232.     fname    <ACCEPT>    ; c-addr +n1 -- +n2
  2233.     ctok    NEST
  2234.     ctok    OVER
  2235.     ctok    SWAP        ; -- c-a c-a +n1
  2236.     ctok    PACCEPT        ; -- c-a +n2'
  2237.     ctok    DUP        ; -- c-a +n2 +n2
  2238.     compif    accept9
  2239.     ctok    TWO_DUP        ; -- c-a +n2 c-a +n2
  2240.     ctok    CHARS
  2241.     ctok    PLUS        ; -- c-a1 +n2 c-a2
  2242.     literal    2
  2243.     literal    0
  2244.     compdo    accept4
  2245. accept3:
  2246.     literal    1        ; -- c-a1 +n2 c-a2 1
  2247.     ctok    CHARS
  2248.     ctok    MINUS        ; -- c-a1 +n2 c-a2'
  2249.     ctok    DUP
  2250.     ctok    C_FETCH        ; -- c-a1 +n2 c-a2' char
  2251.     ctok    DUP
  2252.     literal    0aH        ; -- c-a1 +n2 c-a2' char char 0aH
  2253.     ctok    EQUAL        ; -- c-a1 +n2 c-a2' char flag
  2254.     ctok    SWAP        ; -- c-a1 +n2 c-a2' flag char
  2255.     literal    0dH        ; -- c-a1 +n2 c-a2' flag char 0dH
  2256.     ctok    EQUAL        ; -- c-a1 +n2 c-a2' flag1 flag2
  2257.     ctok    OR        ; -- c-a1 +n2 c-a2' flag
  2258.     compif    accept8
  2259.     ctok    BL        ; -- c-a1 +n2 c-a2' 020H
  2260.     ctok    OVER        ; -- c-a1 +n2 c-a2' 020H c-a2'
  2261.     ctok    C_STORE        ; -- c-a1 +n2 c-a2'
  2262. accept8:
  2263.     comploop    accept3
  2264. accept4:            ; -- c-a1 +n2 c-a2'
  2265.     ctok    DROP        ; -- c-a1 +n2
  2266. accept9:
  2267.     ctok    NIP        ; -- +n2
  2268. accept_done:
  2269.     ctok    UNNEST
  2270.  
  2271.     znamemanque    <(ACCEPT)>    ; c-addr +n1 -- +n2
  2272. fw_PACCEPT:                ; implementation
  2273.     docode
  2274.     pop    eax
  2275.     and    eax,eax                    ; positive count?
  2276.     jnle    paccept1                ; if yes, continue further on
  2277.     xor    eax,eax                    ; make a zero
  2278.     mov    [esp],eax                ; +n2 = 0 on error
  2279. paccept1:
  2280.     push    eax                    ; preserve count
  2281.     lea    eax,[dp+conMode]            ; in order to preserve con mode
  2282.     INVOKE    GetConsoleMode, [dp+stdIn], eax    ; let's find out what it is
  2283.     and    eax,eax                    ; success is "C" TRUE
  2284.     jne    paccept2                ; if GetConsoleMode succeeds, continue
  2285.     pop    eax                    ; discard count
  2286.     xor    eax,eax                    ; make a zero
  2287.     mov    [esp],eax                ; n2 = 0 on error
  2288.     jmp    doLastErr                ; return to NEXT via doLastErr
  2289. paccept2:
  2290.     INVOKE    SetConsoleMode, [dp+stdIn], ENABLE_ECHO_INPUT OR ENABLE_LINE_INPUT OR ENABLE_PROCESSED_INPUT
  2291.                             ; set echo, line input, processed handling
  2292.     and    eax,eax                    ; success is "C" TRUE
  2293.     jne    paccept3                ; if SetConsoleMode succeeds, continue
  2294.     pop    eax                    ; discard count
  2295.     xor    eax,eax                    ; make a zero
  2296.     mov    [esp],eax                ; n2 = 0 on error
  2297.     jmp    doLastErr                ; return to NEXT via doLastErr
  2298. paccept3:
  2299.     pop    eax                    ; count
  2300.     pop    edx                    ; destination
  2301.     add    edx,dp                    ; abs address of destination
  2302.     INVOKE    ReadConsoleW, [dp+stdIn], edx, eax, OFFSET FLAT:numRead,0    ; get a line of input
  2303.     and    eax,eax                    ; "C" TRUE is success
  2304.     jne    paccept4                ; on success, continue elsewhere
  2305.     push    eax
  2306.     jmp    doLastErr                ; failure, get error code
  2307. paccept4:
  2308.     mov    DWORD PTR lastError[dp],TRUE    ; success, return TRUE, no Windows error code has all bits set
  2309.     mov    eax,DWORD PTR numRead        ; how many did we get?
  2310.     push    eax                ; this is: -- +n2
  2311.     mov    eax,conMode[dp]            ; get saved console mode
  2312.     INVOKE    SetConsoleMode, [dp+stdIn], eax    ; restore previous console mode, don't worry about err here
  2313.     next
  2314.  
  2315. ;--( Data Space and the Dictionary )
  2316.  
  2317.     zname    <UNFOUND>    ; --
  2318.     ctok    NEST        ; Implementation 
  2319.     literal    -13
  2320.     ctok    THROW
  2321.  
  2322. ; Can't use our name header macros with this one!
  2323.     linkme    flinkptr
  2324.     countcell    1
  2325.     db    "'",0        ; -- xt | abort
  2326.     align    4        ; CORE
  2327. fw_TICK:
  2328.     ctok    NEST
  2329.     ctok    BL
  2330.     ctok    WORD
  2331.     ctok    FIND
  2332.     ctok    ZEROEQ
  2333.     compif    tick1
  2334.     ctok    UNFOUND
  2335. tick1:    ctok    UNNEST
  2336.  
  2337. ; Can't use our name header macros with this one!
  2338.     linkme    flinkptr
  2339.     countcell    <3 or immedMask>
  2340.     db    '[',0,"'",0,']',0    ; -- | abort
  2341.     align    4            ; CORE
  2342. fw_BRACKETTICK:
  2343.     ctok    NEST
  2344.     ctok    STATEABORT
  2345.     ctok    TICK
  2346.     ctok    LITERAL
  2347.     ctok    UNNEST
  2348.  
  2349.     fname    <ALIGN>        ; --
  2350.     ctok    NEST        ; CORE
  2351.     literal    cell        ; -- 4
  2352.     ctok    HERE        ; -- 4 addr
  2353.     literal    cell-1        ; -- 4 addr 3
  2354.     ctok    AND        ; -- 4 xx
  2355.     ctok    DUP        ; -- 4 xx xx
  2356.     compif    align1        ; -- 4 xx    "extra bits" indicating cell alignment?
  2357.     ctok    MINUS        ; -- n        address now aligned, but a cell short
  2358.     ctok    ALLOT        ; --        now it's ok
  2359.     ctok    EXIT
  2360. align1:    ctok    TWO_DROP    ; 4 xx --
  2361.     ctok    UNNEST
  2362.         
  2363.     fname    <ALIGNED>    ; addr -- a-addr
  2364.     ctok    NEST        ; CORE
  2365.     ctok    DUP        ; -- a a
  2366.     literal    cell-1        ; -- a a n
  2367.     ctok    AND        ; -- a x
  2368.     ctok    DUP        ; -- a x x
  2369.     compif    aligned1    ; -- a x    "extra bits" indicating cell alignment?
  2370.     ctok    MINUS        ; -- a-a'    address now aligned, but a cell short
  2371.     literal    cell        ; -- a-a' n
  2372.     ctok    PLUS        ; -- a-a
  2373.     ctok    EXIT
  2374. aligned1:            ; -- a-a x    no "extra bits"
  2375.     ctok    DROP        ; -- a-a
  2376.     ctok    UNNEST
  2377.  
  2378.     fname    <ALLOT>        ; n --
  2379.     dd    allot        ; CORE
  2380. allot:    pop    eax
  2381.     add    datap[dp],eax
  2382.     next
  2383.  
  2384.     fnamemanque    <CELL+>    ; a-addr1 -- a-addr2
  2385. fw_CELL_PLUS:            ; CORE
  2386.     dd    cell_plus
  2387. cell_plus:
  2388.     add    DWORD PTR [esp],cell
  2389.     next
  2390.  
  2391.     fname    <CELLS>        ; n1 -- n2
  2392.     ctok    NEST        ; CORE
  2393.     literal    cell
  2394.     ctok    STAR
  2395.     ctok    UNNEST
  2396.  
  2397.     fnamemanque    <FORTH-WORDLIST>    ; -- wid
  2398. fw_FWORDLIST:            ; SEARCH
  2399.     ctok    DOKWORDLIST
  2400.     dd    flinkp        ; pointer to data address of of last word added to list
  2401.     dd    0        ; token of next wordlist in link
  2402.  
  2403.     fnamemanque    <INTERNALS-WORDLIST>    ; -- wid
  2404. fw_ZWORDLIST:            ; Implementation
  2405.     ctok    DOKWORDLIST
  2406.     dd    zlinkp        ; pointer to data address of of last word added to list
  2407.     ctok    FWORDLIST    ; token of next wordlist in link
  2408.  
  2409.     fnamemanque    <NONSTANDARD-WORDLIST>    ; -- wid
  2410. fw_NWORDLIST:            ; Implementation
  2411.     ctok    DOKWORDLIST
  2412.     dd    nlinkp        ; pointer to data address of of last word added to list
  2413.     ctok    ZWORDLIST    ; token of next wordlist in link
  2414.  
  2415.     fnamemanque    <SYSTEM-WORDLIST>    ; -- wid
  2416. fw_SWORDLIST:            ; Implementation
  2417.     ctok    DOKWORDLIST
  2418.     dd    slinkp        ; pointer to data address of of last word added to list
  2419.     ctok    NWORDLIST    ; token of next wordlist in link
  2420.  
  2421.     fname    <FORTH>        ; --
  2422.     ctok    NEST        ; SEARCH EXT
  2423.     ctok    GET_ORDER
  2424.     ctok    QDUP
  2425.     compif    forth1
  2426.     ctok    NIP
  2427.     ctok    FWORDLIST
  2428.     ctok    SWAP
  2429.     ctok    SET_ORDER
  2430.     ctok    EXIT
  2431. forth1:    ctok    FWORDLIST
  2432.     literal    1
  2433.     ctok    SET_ORDER
  2434.     ctok    UNNEST
  2435.     
  2436.     fnamemanque    <SET-CURRENT>    ; wid --
  2437. fw_SET_CURRENT:                ; SEARCH
  2438.     docode
  2439.     pop    DWORD PTR current[dp]    ; store wid to the current compilation wordlist variable
  2440.     next
  2441.  
  2442.     fnamemanque    <GET-CURRENT>    ; -- wid
  2443. fw_GET_CURRENT:                ; SEARCH
  2444.     dd    get_current
  2445. get_current:
  2446.     push    DWORD PTR current[dp]
  2447.     next
  2448.  
  2449.     fnamemanque    <SET-ORDER>    ; wid1 .. widn n --
  2450. fw_SET_ORDER:                ; SEARCH
  2451.     ctok    NEST
  2452.     ctok    DUP
  2453.     literal    searchOrderSize
  2454.     ctok    GREATER            ; no bogus indices, please!
  2455.     literal    -49            ; search order overflow THROW
  2456.     ctok    AND
  2457.     ctok    THROW
  2458.     ctok    DUP
  2459.     ctok    ZEROLT
  2460.     literal    -50            ; search order underflow THROW
  2461.     ctok    AND
  2462.     ctok    THROW
  2463.     literal    searchOrderSize
  2464.     literal    0
  2465.     compqdo    set_order1
  2466. set_order0:                ; loop clearing search order
  2467.     ctok    FALSE
  2468.     literal    searchOrder
  2469.     ctok    I
  2470.     ctok    CELLS
  2471.     ctok    PLUS
  2472.     ctok    STORE
  2473.     comploop    set_order0
  2474. set_order1:
  2475.     literal    0
  2476.     compqdo    set_order3        ; ?DO since 0 is a legit argument
  2477. set_order2:                ; loop filling cells, (if any
  2478.     literal    searchOrder
  2479.     ctok    I
  2480.     ctok    CELLS
  2481.     ctok    PLUS
  2482.     ctok    STORE
  2483.     comploop    set_order2
  2484. set_order3:
  2485.     ctok    UNNEST
  2486.  
  2487.     fname    <WORDLIST>    ; -- wid
  2488.     ctok    NEST        ; SEARCH
  2489.     literal    unnamedHdr
  2490.     ctok    ABSTODATA
  2491.     ctok    COUNT
  2492.     ctok    NAMEWORDLIST
  2493.     ctok    UNNEST
  2494.  
  2495.     fname    <MARKER>    ; "<spaces>name" --
  2496.     ctok    NEST        ; CORE EXT
  2497.     literal    wllink
  2498.     ctok    FETCH        ; -- xt ,wordlist link contains an xt
  2499.     literal    0
  2500.     literal    0        ; -- xt 0 0 ,mark end of wordlists
  2501.     literal    2
  2502.     ctok    PICK        ; -- xt 0 0 xt ,get a copy of wordlist link
  2503. marker0:
  2504.     ctok    DUP        ; -- xt0 0 0 xt xt ,check for zero
  2505.     compif    marker1
  2506.     ctok    TOKENTODATA    ; -- xt0 0 0 a-addr
  2507.     ctok    CELL_PLUS    ; -- xt0 0 0 a-addr' ,now we point to pointer to list pointer
  2508.     ctok    DUP        ; -- xt0 0 0 a-addr' a-addr'
  2509.     ctok    FETCH        ; -- xt0 0 0 a-addr' a-addr'' ,data address holds last word's link for this wid
  2510.     ctok    DUP        ; -- xt0 0 0 a-addr' a-addr'' a-addr''
  2511.     ctok    FETCH        ; -- xt0 0 0 a-addr' linkp ,pointer to last word in that wordlist
  2512.     ctok    ROT        ; -- xt0 0 0 a-addr'' linkp a-addr'
  2513.     ctok    CELL_PLUS    ; -- xt0 0 0 a-addr'' linkp a-addr''' move to back link to previous wordlist
  2514.     ctok    FETCH        ; -- xt0 0 0 a-addr'' linkp xt2
  2515.     compelse    marker0    ; loop and keep piling them up
  2516. marker1:            ; we get here when we run out of wids
  2517.     ctok    DROP        ; -- xt0 0 0 a-addrn linkpn ... a-addrz linkpz
  2518.     ctok    DP        ; -- .. a-addrz linkpz a-addr
  2519.     ctok    FETCH        ; -- .. a-addrz linkpz abs-addr
  2520.     literal    last
  2521.     ctok    FETCH        ; -- .. a-addrz linkpz abs-addr a-addr ,"last" pointer
  2522.     ctok    ALIGN        ; for good luck
  2523.     ctok    CREATE        ; now create this forgettable dictionary entry
  2524.     ctok    DOLIT
  2525.     ctok    DOMARKER    ; runtime engine for MARKER
  2526.     ctok    MAKEDOES    ; "does" the new word to DOMARKER
  2527.     ctok    COMMA        ; save "last" pointer
  2528.     ctok    COMMA        ; save dictionary pointer
  2529. marker2:
  2530.     ctok    TWO_DUP        ; -- .. a-addrz linkpz
  2531.     ctok    COMMA        ; a last-word pointer
  2532.     ctok    COMMA        ; a wid's data body address where it stores its last word pointer
  2533.     ctok    D_ZEROEQ    ; is this a zero-zero?
  2534.     ctok    INVERT
  2535.     compif    marker3        ; if not, we continue
  2536.     compelse    marker2    ; this is the continuing
  2537. marker3:
  2538.     ctok    COMMA        ; and there's the wordlist pointer
  2539.     ctok    UNNEST
  2540.  
  2541.     zname    <DOMARKER>    ; data-address --
  2542.     ctok    NEST
  2543.     ctok    DUP        ; -- a-addr a-addr
  2544.     literal    datap        ; -- a-addr1 a-addr1 a-addr2
  2545.     ctok    STORE        ; -- a-addr
  2546.     ctok    DUP        ; -- a-addr a-addr
  2547.     ctok    FETCH        ; -- a-addr linkp
  2548.     literal    last        ; -- a-addr1 linkp a-addr2 ,restore "last" pointer
  2549.     ctok    STORE        ; -- a-addr
  2550.     ctok    CELL_PLUS    ; -- a-addr' ,go to next cell
  2551.     ctok    DUP        ; -- a-addr a-addr
  2552.     ctok    FETCH        ; -- a-addr dp
  2553.     ctok    DP        ; -- a-addr1 dp a-addr2 ,restore dictionary pointer
  2554.     ctok    STORE        ; -- a-addr
  2555.     ctok    CELL_PLUS    ; -- a-addr'
  2556. domarker0:
  2557.     ctok    DUP        ; -- a-addr a-addr ,here we go for the wordlists
  2558.     ctok    TWO_FETCH    ; -- a-addr wid-body last-word
  2559.     ctok    TWO_DUP        ; -- a-addr wid-body last-word wid last-word
  2560.     ctok    OR        ; -- a-addr wid-body last-word flag
  2561.     compif    domarker1    ; we're done if it's zero-zero
  2562.     ctok    SWAP        ; -- a-addr last-word wid-body
  2563.     ctok    STORE        ; -- a-addr ,restore a wordlist's last pointer
  2564.     ctok    CELL_PLUS    ; -- ''
  2565.     ctok    CELL_PLUS    ; -- a-addr''' ,our next fetch will be two cells ahead
  2566.     compelse domarker0    ; and do it again
  2567. domarker1:            ; we're done restoring wids
  2568.     ctok    TWO_DROP    ; -- a-addr ,we didn't use the last (null) pair
  2569.     ctok    CELL_PLUS    ; -- a-addr'
  2570.     ctok    CELL_PLUS    ; -- a-addr' (past the last NULL wordlist pair we used to mark end)
  2571.     ctok    FETCH        ; -- wid , get the wordlist link
  2572.     literal    wllink        ; -- wid a-addr
  2573.     ctok    STORE        ; -- we're done
  2574.     ctok    UNNEST
  2575.  
  2576.     nname    <NAMEWORDLIST>    ; c-addr u -- wid
  2577.     ctok    NEST
  2578.     ctok    HEADER        ; make (possibly headerless) header
  2579.     ctok    LINKIT        ; ... and link it in current wordlist
  2580.     ctok    DP
  2581.     ctok    FETCH        ; save dictionary pointer to convert to token for this wordlist
  2582.     ctok    DOLIT
  2583.     ctok    DOKWORDLIST    ; embed wordlist engine
  2584.     ctok    COMPCOMMA
  2585.     ctok    HERE        ; pointer to the link pointer for this wordlist
  2586.     ctok    COMPCOMMA
  2587.     literal    1
  2588.     ctok    CELLS
  2589.     ctok    ALLOT        ; allot storage for that link pointer
  2590.     literal    wllink
  2591.     ctok    FETCH
  2592.     ctok    COMPCOMMA    ; compile back pointer to previous wordlist
  2593.     ctok    MAKETOKEN    ; convert that dictionary pointer sitting on the stack to a user token
  2594.     ctok    DUP        ; save copy
  2595.     literal    wllink
  2596.     ctok    STORE        ; store that token in the wordlist link pointer as last wordlist added
  2597.     ctok    EXECUTE        ; return own WID
  2598.     ctok    UNNEST
  2599.  
  2600.     nname    <WORDLISTS>    ; --
  2601.     ctok    NEST        ; Not in Standard
  2602.     ctok    CR
  2603.     literal    wlHdr
  2604.     ctok    ABSTODATA
  2605.     ctok    COUNT
  2606.     ctok    TYPE
  2607.     literal    wllink
  2608. wordlists1:
  2609.     ctok    FETCH        ; -- xt, token of wordlist
  2610.     ctok    QDUP        ; -- xt xt|-
  2611.     compif    wordlists2    ; -- xt
  2612.     ctok    TOKENTODATA    ; -- a-addr
  2613.     ctok    DATATOABS    ; -- abs-addr, convert for printing wid as it is
  2614.     ctok    CELL_PLUS    ; -- abs-addr', the wid is the abs addr of the cell past cfa
  2615.     ctok    DUP        ; -- abs abs
  2616.     ctok    DOT_WID        ; -- abs
  2617.     ctok    SPACE
  2618.     ctok    CELL_PLUS    ; -- abs-addr of wordlist link pointer
  2619.     ctok    ABSTODATA    ; -- a-addr, read for next go-round
  2620.     compelse    wordlists1
  2621. wordlists2:            ; --
  2622.     ctok    CR
  2623.     ctok    UNNEST
  2624.  
  2625.     fname    <WORDS>    ; --
  2626.     ctok    NEST    ; TOOLKIT
  2627.     ctok    CR
  2628.     literal    searchOrder
  2629.     ctok    FETCH        ; -- wid
  2630.     ctok    ABSTODATA    ; -- addr of pointer to thread
  2631.     ctok    FETCH        ; -- addr of thread
  2632. words1:
  2633.     ctok    FETCH        ; -- link-token
  2634.     ctok    QDUP        ; is it null
  2635.     compif    words5        ; if null, we're done
  2636.     ctok    DUP        ; -- lt lt
  2637.     ctok    DOT_WORD    ; -- lt
  2638.     ctok    TOKENTODATA    ; -- a-addr
  2639.     ctok    KEY_Q        ; -- a-addr flag, has user punched for quick exit or pause?
  2640.     compif    words1        ; -- a-addr, if no keypress, loop again
  2641. words2:                ; -- a-addr, here's where we get if there was a keypress
  2642.     ctok    KEY        ; -- a-addr char
  2643.     ctok    BL        ; -- a-addr c1 c2
  2644.     ctok    EQUAL        ; -- a-addr flag, was it a space bar?
  2645.     compif    words4        ; -- a-addr, if not, it's a quit.
  2646. words3:                ; -- a-addr, it was a space bar
  2647.     ctok    KEY        ; -- a-addr char, we waited for user to punch again
  2648.     ctok    BL        ; -- a-addr c1 c2
  2649.     ctok    NEQUAL        ; -- a-addr flag, if it's a space bar, resume
  2650.     compif    words1        ; -- a-addr, but if it's anything else, quit
  2651. words4:                ; -- a-addr, we fall thru here if key was NEQUAL to a space bar
  2652.     ctok    DROP        ; -- , discard address, quick exit
  2653. words5:
  2654.     ctok    CR        ; -- , new line
  2655.     ctok    UNNEST
  2656.  
  2657.     fnamemanque    <GET-ORDER>    ; ( -- wid1 .. widn n)
  2658. fw_GET_ORDER:                ; SEARCH
  2659.     ctok    NEST
  2660.     literal    0            ; holder, -- 0
  2661.     literal    searchOrderSize        ; -- 0 n
  2662.     literal    0            ; -- 0 n 0
  2663.     compqdo    get_order2
  2664. get_order0:                ; -- 0
  2665.     literal    searchOrder        ; -- 0 a-addr
  2666.     ctok    I            ; -- 0 a-addr n
  2667.     ctok    CELLS            ; -- 0 a-addr n'
  2668.     ctok    PLUS            ; -- 0 a-addr'
  2669.     ctok    FETCH            ; -- 0 wid
  2670.     ctok    ZEROEQ            ; -- 0 flag
  2671.     compif    get_order1
  2672.     ctok    LEAVE            ; -- 0
  2673. get_order1:
  2674.     ctok    ONE_PLUS        ; -- 0+1
  2675.     comploop    get_order0
  2676. get_order2:
  2677.     ctok    DUP            ; -- index index
  2678.     literal    0            ; -- index index 0
  2679.     compqdo    get_order4        
  2680. get_order3:                ; -- index
  2681.     ctok    DUP            ; -- index index
  2682.     ctok    ONE_MINUS        ; -- index index'
  2683.     ctok    CELLS            ; -- index n
  2684.     literal    searchOrder        ; -- index n a-addr
  2685.     ctok    PLUS            ; -- index a-addr'(last cell with a valid wid in it)
  2686.     ctok    I
  2687.     ctok    CELLS    
  2688.     ctok    MINUS            ; -- index a-addr''
  2689.     ctok    FETCH            ; -- index wid
  2690.     ctok    SWAP            ; -- wid index
  2691.     comploop    get_order3
  2692. get_order4:
  2693.     ctok    UNNEST
  2694.  
  2695.     fname    <ORDER>            ; --
  2696.     ctok    NEST            ; SEARCH EXT
  2697.     ctok    CR
  2698.     literal    orderMsg0
  2699.     ctok    ABSTODATA
  2700.     literal    orderMsg0Len
  2701.     ctok    TYPE            ; --         display text
  2702.     ctok    GET_ORDER
  2703.     literal    0
  2704.     compqdo    order1
  2705. order0:    ctok    DOT_WID            ; --         print each wid and its name
  2706.     comploop    order0
  2707. order1:    ctok    CR
  2708.     ctok    CR
  2709.     literal    orderMsg1
  2710.     ctok    ABSTODATA
  2711.     literal    orderMsg1Len
  2712.     ctok    TYPE            ; --         display text
  2713.     ctok    GET_CURRENT
  2714.     ctok    QDUP
  2715.     compif    order2
  2716.     ctok    DOT_WID            ; --         print each wid
  2717. order2:    ctok    CR
  2718.     ctok    UNNEST
  2719.  
  2720.     nnamemanque    <.NAME>    ; c-addr --
  2721. fw_DOT_NAME:            ; Implementation
  2722.     ctok    NEST
  2723.     ctok    COUNT
  2724.     literal    allNameMasks
  2725.     ctok    INVERT
  2726.     ctok    AND
  2727.     ctok    TWO_DUP
  2728.     literal    unnamedHdr
  2729.     ctok    ABSTODATA
  2730.     ctok    COUNT
  2731.     ctok    COMPARE
  2732.     ctok    ZERONE
  2733.     compif    dot_name1
  2734.     ctok    TYPE
  2735.     ctok    SPACE
  2736.     compelse    dot_name2
  2737. dot_name1:
  2738.     ctok    TWO_DROP
  2739. dot_name2:
  2740.     ctok    UNNEST
  2741.  
  2742.     nnamemanque    <.WID>    ; wid --
  2743. fw_DOT_WID:            ; Implementation
  2744.     ctok    NEST
  2745.     ctok    CR        ; one per line
  2746.     ctok    BASE        ; get and save base
  2747.     ctok    FETCH
  2748.     ctok    TO_R        ; -- wid            R: -- base
  2749.     ctok    HEX        ; switch to hex
  2750.     ctok    DUP        ; -- wid wid            R: -- base
  2751.     literal    8
  2752.     ctok    U_DOT_R        ; -- wid            R: -- base
  2753.                 ;  print wid in hex, right justified
  2754.     literal    widMsg        ; -- wid abs-addr        R: -- base
  2755.     ctok    ABSTODATA    ; data address
  2756.     ctok    COUNT
  2757.     ctok    TYPE        ; display it
  2758.     ctok    SPACE        ; -- wid            R: -- base
  2759.     ctok    ABSTODATA    ; -- a-addr            R: -- base
  2760.     literal    -1
  2761.     ctok    CELLS
  2762.     ctok    PLUS        ; -- a-addr of code field    R: -- base
  2763.     ctok    EXETONAME    ; convert  to name
  2764.     ctok    DOT_NAME    ; print it if it's got one
  2765.     ctok    R_FROM        ; -- base            R: --
  2766.     ctok    BASE        ; -- base a-addr        R: --
  2767.     ctok    STORE        ; -- ,restore base
  2768.     ctok    UNNEST
  2769.  
  2770.     znamemanque    <.WORD>    ; link-token --
  2771. fw_DOT_WORD:            ; Implementation
  2772.     ctok    NEST
  2773.     ctok    TOKENTODATA
  2774.     ctok    LINKTONAME
  2775.     ctok    DOT_NAME
  2776.     ctok    UNNEST
  2777.  
  2778.     fname    <ALSO>        ; --
  2779.     ctok    NEST        ; SEARCH EXT
  2780.     ctok    GET_ORDER
  2781.     ctok    OVER
  2782.     ctok    SWAP
  2783.     ctok    ONE_PLUS
  2784.     ctok    SET_ORDER
  2785.     ctok    UNNEST
  2786.  
  2787.     fname    <PREVIOUS>    ; --
  2788.     ctok    NEST        ; SEARCH EXT
  2789.     ctok    GET_ORDER
  2790.     ctok    DUP
  2791.     literal    2
  2792.     ctok    LESS
  2793.     literal    -50
  2794.     ctok    AND
  2795.     ctok    THROW        ; search order underflow THROW
  2796.     ctok    NIP
  2797.     ctok    ONE_MINUS
  2798.     ctok    SET_ORDER
  2799.     ctok    UNNEST
  2800.  
  2801.     fname    <ONLY>        ; --
  2802.     ctok    NEST        ; SEARCH EXT
  2803.     ctok    FWORDLIST
  2804.     literal    1
  2805.     ctok    SET_ORDER
  2806.     ctok    UNNEST
  2807.  
  2808.     fname    <DEFINITIONS>    ; --
  2809.     ctok    NEST        ; SEARCH EXT
  2810.     literal    searchOrder
  2811.     ctok    FETCH
  2812.     ctok    SET_CURRENT
  2813.     ctok    UNNEST
  2814.  
  2815.     fnamemanque    <SEARCH-WORDLIST>    ; c-addr u wid -- 0 | xt 1 | xt -1)
  2816. fw_SEARCH_WL:                    ; SEARCH
  2817.     ctok    NEST
  2818.     ctok    ABSTODATA            ; -- a-addr, of pointer to data-address
  2819.     ctok    FETCH                ; -- a-addr, data location of last link
  2820.     ctok    FETCH                ; -- ltok, last link in the wordlist
  2821. search_wl0:
  2822.     ctok    DUP                ; is link to zero (end of list)
  2823.     compif    search_wl_fail            ; No, it's a real link
  2824.     ctok    TO_R                ; save copy of ltoken
  2825.     ctok    TWO_DUP                ; -- c-a u c-a u    R: -- ltoken
  2826.     ctok    R_FETCH                ; -- c-a u c-a u ltoken    R: -- ltoken
  2827.     ctok    TOKENTODATA            ; -- c-a u c-a u a-a    R: -- ltoken
  2828.     ctok    LINKTONAME            ; -- c-a1 u c-a1 u c-a2    R: -- ltoken
  2829.     ctok    DUP
  2830.     ctok    TO_R                ; -- c-a1 u c-a1 u c-a2    R: -- ltoken name-address    
  2831.     ctok    COUNT                ; -- c-a1 u1 c-a1 u1 c-a2 u2+mask
  2832.     literal    allNameMasks            ; unmask name count byte
  2833.     ctok    INVERT
  2834.     ctok    AND
  2835.     ctok    COMPARE                ; -- c-a1 u1 0|1|-1    R: -- ltoken name-address
  2836.     ctok    ZEROEQ                ; -- c-a1 u1 flag    R: -- ltoken name-address
  2837.     compif    search_wl4            ; Zero? We found it
  2838.     ctok    TWO_DROP            ; --            R: -- ltoken name-address
  2839.     ctok    R_FROM                ; -- name-address    R: -- ltoken
  2840.     ctok    C_FETCH                ; -- count-word+mask    R: -- ltoken
  2841.     literal    immedMask
  2842.     ctok    AND                ; -- bit        R: -- ltoken
  2843.     compif    search_wl1
  2844.     literal    1                ; -- 1            R: -- ltoken
  2845.     compelse    search_wl2
  2846. search_wl1:                    ; -- -1            R: -- ltoken
  2847.     literal    -1
  2848. search_wl2:
  2849.     ctok    R_FROM                ; -- n ltoken
  2850.     ctok    DUP                ; -- n ltoken ltoken
  2851.     ctok    TOKENTODATA            ; -- n ltoken a-addr(link)
  2852.     ctok    LINKTOEXE            ; -- n ltoken a-addr'
  2853.     ctok    DATATOABS            ; -- n ltoken abs-addr
  2854.     ctok    SWAP                ; -- n a-addr' ltoken 
  2855.     ctok    USERTOKENQ            ; -- n a-addr' flag
  2856.     compif    search_wl3            ; -- is this in user dictionary?
  2857.     ctok    ABSTOCODE            ; yes, convert to code token
  2858.     ctok    MAKETOKEN            ; -- n xt
  2859. search_wl3:                    ; -- no, abs address is valid xt for kernel words
  2860.     ctok    SWAP                ; -- xt 1|-1
  2861.     ctok    EXIT
  2862. search_wl4:                    ; didn't match, -- c-a1 u1    R: -- ltoken name-address
  2863.     ctok    R_FROM
  2864.     ctok    DROP                ; -- c-a1 u1        R: -- ltoken
  2865.     ctok    R_FROM                ; -- c-a1 u1 ltoken    R: --
  2866.     ctok    TOKENTODATA            ; -- c-a u a-addr
  2867.     ctok    FETCH                ; -- c-a u next-link-tok
  2868.     compelse    search_wl0        ; try again
  2869. search_wl_fail:                    ; ran out of links, -- c-a u ltoken
  2870.     ctok    DROP
  2871.     ctok    TWO_DROP                ; --
  2872.     ctok    FALSE                ; -- 0
  2873.     ctok    UNNEST
  2874.  
  2875.     fname    <HERE>        ; -- addr
  2876.     dd    here        ; execution engine
  2877. here:    push    [dp+datap]    ; CORE
  2878.     next
  2879.  
  2880. ; Convert token such as link pointer or execution token to data-relative address
  2881.     zname    <TOKENTODATA>    ; linkt|xt -- a-addr
  2882.     ctok    NEST        ; Implementation
  2883.     ctok    DUP
  2884.     ctok    USERTOKENQ
  2885.     compif    t_to_data1
  2886.     ctok    DETOKEN
  2887.     ctok    CODETODATA
  2888.     ctok    EXIT
  2889. t_to_data1:
  2890.     ctok    ABSTODATA
  2891.     ctok    UNNEST
  2892.  
  2893. ; All these convert from one data-relative address to another. LINK is the link address. EXE is the address
  2894. ; which is represented by the execution token for the word. NAME is the count word address at the head of
  2895. ; the name field, not the FFFF word before it.
  2896.  
  2897.     zname    <EXETOLINK>    ; a-addr1 -- a-addr2
  2898.     ctok    NEST        ; Implementation
  2899.     ctok    EXETONAME
  2900.     ctok    NAMETOLINK
  2901.     ctok    UNNEST
  2902.  
  2903.     zname    <LINKTOEXE>    ; a-addr1 -- a-addr2
  2904.     ctok    NEST        ; Implementation
  2905.     ctok    LINKTONAME
  2906.     ctok    NAMETOEXE
  2907.     ctok    UNNEST
  2908.  
  2909.     zname     <NAMETOLINK>    ; c-addr -- a-addr
  2910.     ctok    NEST        ; Implementation
  2911.     literal    1
  2912.     ctok    CHARS
  2913.     ctok    MINUS        ; back past the FFFF marker word
  2914.     literal    1
  2915.     ctok    CELLS
  2916.     ctok    MINUS        ; back to head of link field
  2917.     ctok    UNNEST
  2918.  
  2919.     zname    <LINKTONAME>    ; a-addr -- c-addr
  2920.     ctok    NEST        ; Implementation
  2921.     literal    1
  2922.     ctok    CELLS
  2923.     ctok    PLUS        ; past link field
  2924.     literal    1
  2925.     ctok    CHARS
  2926.     ctok    PLUS        ; past the FFFF marker word
  2927.     ctok    UNNEST
  2928.  
  2929.     zname    <NAMETOEXE>    ; c-addr -- a-addr
  2930.     ctok    NEST
  2931.     ctok    COUNT
  2932.     literal    allNameMasks
  2933.     ctok    INVERT
  2934.     ctok    AND        ; mask out all "funny" bits in count word
  2935.     ctok    CHARS
  2936.     ctok    PLUS
  2937.     ctok    ALIGNED
  2938.     ctok    UNNEST
  2939.  
  2940.     zname    <EXETONAME>    ; a-addr -- c-addr
  2941.     ctok    NEST
  2942. exetoname1:
  2943.     literal    1
  2944.     ctok    CHARS
  2945.     ctok    MINUS
  2946.     ctok    DUP
  2947.     ctok    C_FETCH
  2948.     literal    UniNotAChar
  2949.     ctok    EQUAL
  2950.     compuntil    exetoname1
  2951.     ctok    CHAR_PLUS
  2952.     ctok    UNNEST
  2953.     
  2954. ;--( Interpreter )
  2955.  
  2956.     fname    <BLK>        ; -- a-addr
  2957.     ctok    DOCONST        ; CORE
  2958.     dd    var_blk
  2959.  
  2960.  
  2961.     fname    <FIND>        ; ( c-addr -- c-addr 0 | xt 1 | xt -1 )
  2962.     ctok    NEST        ; CORE
  2963.     ctok    DUP        ; -- $addr
  2964.     ctok    C_FETCH        ; -- $addr u
  2965.     compif    _4find        ; IF the count is non-zero
  2966.     literal    searchOrder    ; -- $addr addr
  2967.     literal    cell        ; -- $addr addr n
  2968.     ctok    MINUS        ; back up to one cell before beginning of search order array
  2969.     ctok    SWAP        ; ptr-to-wid $addr
  2970.     ctok    FALSE        ; ptr-to-wid $addr 0(place holder for DROP of SEARCH-WORDLIST result in loop)
  2971.     ctok    FALSE        ; ptr-to-wid $addr 0(place holder for DROP of DUPed flag SEARCH-WORDLIST in loop)
  2972.     literal    searchOrderSize    ; number of vocabularies in search order
  2973.     literal    0
  2974.     compdo    _3find        ; loop until success or run out of search order
  2975. _0find:                ; -- ptr-to-wid $addr 0 0
  2976.     ctok    TWO_DROP    ; -- ptr-to-wid $addr
  2977.     literal    cell        ; -- ptr-to-wid $addr n
  2978.     ctok    ROT        ; -- $addr n ptr-to-wid
  2979.     ctok    PLUS        ; -- ptr-to-wid $addr
  2980.     ctok    SWAP        ; -- ptw $addr
  2981.     ctok    OVER        ; -- ptr-to-wid $addr ptr-to-wid
  2982.     ctok    FETCH        ; -- ptw $addr wid|0
  2983.     ctok    QDUP        ; we may have reached end of search order
  2984.     compif    _1find        ; -- ptw $addr wid ,valid vocabulary pointer
  2985.     ctok    OVER        ; -- ptw $addr wid $addr
  2986.     ctok    COUNT        ; -- ptw $addr wid c-addr u
  2987.     ctok    ROT        ; -- ptw $addr c-addr u wid
  2988.     ctok    SEARCH_WL    ; -- ptw $a1 [[ 0 ]|[ exetok [ -1|1 ]]]
  2989.     ctok    DUP        ; -- ptw $a1 [[ 0 0 ]|[ exetok [ -1|1 ] [-1|1]]]
  2990.     ctok    ZEROEQ
  2991.     compif    yfind
  2992.     ctok    DUP        ; -- ptw $a1 x1 x2
  2993. yfind:    compelse    _2find    ; NULL in CONTEXT at this entry
  2994. _1find:                ; -- ptw $addr ,invalid wid ptr, end of order
  2995.     ctok    NIP        ; -- $addr
  2996.     ctok    FALSE        ; -- $addr 0
  2997.     ctok    UNLOOP        ; -- $addr 0
  2998.     ctok    EXIT        ; -- c-addr 0
  2999. _2find:                ; -- ptw $addr x1 x2
  3000.     ctok    DUP        ; -- ptw $addr x1 x2 x2
  3001.     compif    xfind        ; -- ptw $addr x [-1|0|1]
  3002.     ctok    LEAVE        ; -- ptw $a1 x x
  3003. xfind:    comploop    _0find
  3004. _3find:                ; -- ptw $a1 xt flag1
  3005.     ctok    ROT
  3006.     ctok    DROP        ; -- ptw xt flag
  3007.     ctok    ROT
  3008.     ctok    DROP        ; -- xt flag
  3009.     ctok    EXIT        ; -- xt flag
  3010. _4find:                ; -- $addr the string was null
  3011.     ctok    TRUE
  3012.     literal    endq        ; var that indicates end of input
  3013.     ctok    STORE
  3014.     ctok    FALSE        ; -- c-addr 0
  3015.     ctok    UNNEST
  3016.  
  3017.     nnamemanque    <?STACK>        ; i*j -- i*j | -
  3018. fw_QSTACK:
  3019.     ctok    NEST        ; implementation
  3020.     ctok    SP0
  3021.     ctok    FETCH        ; original stack pointer    
  3022.     ctok    SP_FETCH    ; current stack pointer
  3023.     literal    cell
  3024.     ctok    PLUS        ; adjusted for presence of orig. stack ptr. on stack
  3025.     ctok    U_LESS        ; has stack underflowed?
  3026.     compif    qstack1
  3027.     literal    -4        ; Stack Underflow Throw
  3028.     ctok    THROW
  3029. qstack1:
  3030.     ctok    UNNEST        ; no, continue
  3031.  
  3032.     zname    <INTERPRET>    ; i*x -- j*x
  3033.     ctok    NEST        ; Not in Standard
  3034. _0inter:            ; Begin
  3035.     ctok    QSTACK        ; --
  3036.     ctok    BL
  3037.     ctok    WORD
  3038.     ctok    FIND        ; -- [ 'word 0 ] | [ cfa 1|-1 ]
  3039.     ctok    QDUP        ; -- [ 'word 0 ] | [ cfa 1|-1 1|-1]
  3040.     compif    _1inter        ; -- cfa 1|-1
  3041.     ctok    STATE
  3042.     ctok    FETCH        ; -- cfa 1|-1 flag
  3043.     compif    _9inter        ; compiling
  3044.     ctok    ZEROLT        ; non-immediate?
  3045.     compif    _8inter        ; yes, compile it
  3046.     ctok    COMPCOMMA    ; --
  3047.     compelse    _0inter    ; --
  3048. _8inter:
  3049.     ctok    EXECUTE        ; --
  3050.     compelse    _0inter    ; --
  3051. _9inter:
  3052.     ctok    DROP        ; -- cfa  ,interpreting
  3053.     ctok    EXECUTE        ; --   ,execute found word
  3054.     literal    endq
  3055.     ctok    FETCH        ; -- t|f ,see if input stream exhausted
  3056.     compif    _0inter        ; -- loop if not exhausted
  3057.     ctok    EXIT        ; -- ,exhausted? exit INTERPRET
  3058. _1inter:
  3059.     literal    endq        ; input stream exhausted?
  3060.     ctok    FETCH        ; -- c-addr flag
  3061.     compif    _5inter        ; if yes we're done, else we might be looking at a number
  3062.     ctok    DROP        ; discard c-addr
  3063.     ctok    EXIT        ; exit INTERPRET
  3064. _5inter:
  3065.     ctok    COUNT        ; -- c-addr1 u1
  3066.     ctok    NUMBER        ; -- d flag
  3067.     ctok    ZEROEQ        ; -- d t|f
  3068.     compif    _zinter        ; wasn't a number in current base, fail
  3069.     ctok    UNFOUND        ; show offending lexical item with "?"
  3070. _zinter:
  3071.     ctok    DPL        ; -- d a-addr        check for double precision
  3072.     ctok    FETCH        ; -- d [ n | -1 ]
  3073.     ctok    TRUE        ; -- d [ n | -1 ] TRUE
  3074.     ctok    EQUAL        ; -- d t|f
  3075.     compif    _6inter        ; -- ud2
  3076.     ctok    DROP        ; -- u  ,drop hi-order if not double precis
  3077.     ctok    STATE        ; -- u addr
  3078.     ctok    FETCH        ; -- u flag
  3079.     compif    _2inter        ; -- u
  3080.     ctok    LITERAL        ; --
  3081.     compelse    _2inter    ; -- u
  3082. _6inter:
  3083.     ctok    STATE        ; -- ud2 addr
  3084.     ctok    FETCH        ; -- ud2 flag
  3085.     compif    _2inter        ; -- ud2
  3086.     ctok    TWO_LITERAL    ; --
  3087. _2inter:                ; Then
  3088.     literal    endq
  3089.     ctok    FETCH        ; -- flag
  3090.     compuntil    _0inter    ; Until
  3091.     ctok    UNNEST
  3092.  
  3093.     fname    <EVALUATE>    ; i*x c-addr u -- j*x
  3094.     ctok    NEST
  3095.     ctok    BLK        ; Save input on return stack
  3096.     ctok    FETCH
  3097.     ctok    TO_R        ; -- i*x c-addr u    R: -- BLK
  3098.     ctok    TIB
  3099.     ctok    TO_R        ; -- i*x c-addr u    R: -- BLK TIB
  3100.     ctok    NUMTIB
  3101.     ctok    FETCH
  3102.     ctok    TO_R        ; -- i*x c-addr u    R: -- BLK TIB #TIB
  3103.     ctok    TO_IN
  3104.     ctok    FETCH
  3105.     ctok    TO_R        ; -- i*x c-addr u    R: -- BLK TIB #TIB >IN
  3106.     ctok    SOURCE_ID
  3107.     ctok    FETCH
  3108.     ctok    TO_R        ; -- i*x c-addr u    R: -- BLK TIB #TIB >IN SID
  3109.     literal    endq
  3110.     ctok    FETCH
  3111.     ctok    TO_R        ; -- i*x c-addr u    R: -- BLK TIB #TIB >IN SID endq
  3112.     ctok    FALSE
  3113.     literal    endq
  3114.     ctok    STORE        ; -- i*x c-addr u    R: -- BLK TIB #TIB >IN SID endq
  3115.     ctok    NUMTIB
  3116.     ctok    STORE        ; -- i*x c-addr        R: -- BLK TIB #TIB >IN SID endq
  3117.     ctok    TICK_TIB
  3118.     ctok    STORE        ; -- i*x         R: -- BLK TIB #TIB >IN SID endq
  3119.     literal    -1
  3120.     ctok    SOURCE_ID
  3121.     ctok    STORE        ; -- i*x c-addr u    R: -- BLK TIB #TIB >IN SOURCE-ID endq
  3122.     ctok    FALSE
  3123.     ctok    BLK
  3124.     ctok    STORE        ; -- i*x c-addr u    R: -- BLK TIB #TIB >IN SOURCE-ID endq
  3125.     ctok    FALSE
  3126.     ctok    TO_IN
  3127.     ctok    STORE        ; -- i*x c-addr u    R: -- BLK TIB #TIB >IN SOURCE-ID endq
  3128.     ctok    INTERPRET    ; -- j*x        R: -- BLK TIB #TIB >IN SOURCE-ID endq
  3129.     ctok    R_FROM        ; Restore input spec
  3130.     literal    endq
  3131.     ctok    STORE        ; -- j*x c-addr u    R: -- BLK TIB #TIB >IN SOURCE-ID
  3132.     ctok    R_FROM    
  3133.     ctok    SOURCE_ID
  3134.     ctok    STORE        ; -- j*x c-addr u    R: -- BLK TIB #TIB >IN
  3135.     ctok    R_FROM
  3136.     ctok    TO_IN
  3137.     ctok    STORE        ; -- j*x c-addr u    R: -- BLK TIB #TIB
  3138.     ctok    R_FROM
  3139.     ctok    NUMTIB
  3140.     ctok    STORE        ; -- j*x c-addr u    R: -- BLK TIB
  3141.     ctok    R_FROM
  3142.     ctok    TICK_TIB
  3143.     ctok    STORE        ; -- j*x c-addr u    R: -- BLK
  3144.     ctok    R_FROM
  3145.     ctok    BLK
  3146.     ctok    STORE        ; -- j*x        R: --
  3147.     ctok    UNNEST
  3148.     
  3149.     znamemanque    <(PARSE)>        ; char "ccc<char>" -- c-addr u
  3150. fw_PPARSE:
  3151.     ctok    NEST            ; this one skips leading delims
  3152.     ctok    SOURCE            ; -- ch c-a u   , get TIB or current BLOCK & char count
  3153.     ctok    TO_IN            ; -- ch c-a u a , get addr of current interp inset var
  3154.     ctok    FETCH            ; -- ch c-a u n , get current inset
  3155.     ctok    SLSTRING        ; -- ch c-a' u'
  3156.     ctok    OVER            ; -- ch c-a' u' c-a'    Need a copy to increment >IN
  3157.     ctok    TO_R            ; -- ch c-a' u'        R: -- c-a'
  3158.     ctok    DUP            ; -- ch c-a' u' u'    R: -- c-a'
  3159.     ctok    ZEROGT            ; -- ch c-a' u' t|f    R: -- c-a'
  3160.     compif    _0parse            ; -- ch c-a' u'        R: -- c-a'
  3161.     literal    2            ; -- ch c-a' u' 2    R: -- c-a'
  3162.     ctok    PICK            ; -- ch c-a' u' ch' , copy of delim char R: -- c-a'
  3163.     ctok    SKIP            ; -- ch c-a'' u'' , skip leading delim     R: -- c-a'
  3164. _9parse:
  3165.     ctok    OVER            ; -- ch c-a'' u'' c-a''    R: -- c-a'
  3166.     ctok    TO_R            ; -- ch c-a'' u'' ,save adr of 1st char R: -- c-a' c-a''
  3167.     ctok    ROT            ; -- c-a' u'' ch    R: -- c-a' c-a''
  3168.     ctok    SCAN            ; -- c-a''' u'''    R: -- c-a' c-a''
  3169.     ctok    DROP            ; -- c-a'''        R: -- c-a' c-a''
  3170.     ctok    R_FROM            ; -- c-a''' c-a''    R: -- c-a'
  3171.     ctok    R_FROM            ; -- c-a''' c-a'' c-a'    R: --
  3172.     literal    2            ; -- c-a''' c-a'' c-a' 2
  3173.     ctok    PICK            ; -- c-a''' c-a'' c-a' c-a'''
  3174.     ctok    SWAP            ; -- c-a''' c-a'' c-a''' c-a'
  3175.     ctok    MINUS            ; -- c-a''' c-a'' n=bytes
  3176.     ctok    TWO_SLASH        ; -- c-a''' c-a'' n=chars
  3177.     ctok    ONE_PLUS        ; account for the character itself which was parsed to.
  3178.     ctok    TO_IN            ; -- c-a''' c-a'' n a
  3179.     ctok    PL_STORE        ; -- c-a''' c-a''
  3180.     ctok    TUCK            ; -- c-a'' c-a''' c-a''
  3181.     ctok    MINUS            ; -- c-addr1 bytes
  3182.     ctok    TWO_SLASH        ; -- c-addr1 u=chars
  3183.     compelse    _1parse        ; -- ch c-a u    R: -- c-a
  3184. _0parse:
  3185.     ctok    R_FROM
  3186.     ctok    DROP            ; -- ch c-a u    R: --
  3187.     ctok    DROP            ; -- ch c-a
  3188.     ctok    NIP            ; -- c-a
  3189.     literal    0            ; -- c-a 0
  3190. _1parse:
  3191.     ctok    UNNEST
  3192.  
  3193.     fname    <PARSE>        ; ( char "ccc<char>" -- c-addr u)
  3194.     ctok    NEST        ; CORE EXT, hits on leading delimiters
  3195.     ctok    SOURCE        ; -- ch c-a u   , get TIB or current BLOCK & char count
  3196.     ctok    TO_IN        ; -- ch c-a u a , get addr of current interp inset var
  3197.     ctok    FETCH        ; -- ch c-a u n , get current inset
  3198.     ctok    SLSTRING    ; -- ch c-a' u'
  3199.     ctok    OVER        ; -- ch c-a' u' c-a'    Need a copy to increment >IN
  3200.     ctok    TO_R        ; -- ch c-a' u'        R: -- c-a'
  3201.     ctok    DUP        ; -- ch c-a' u' u'    R: -- c-a'
  3202.     ctok    ZEROGT        ; -- ch c-a' u' t|f    R: -- c-a'
  3203.     compif    _0parse        ; -- ch c-a' u'        R: -- c-a'
  3204.     compelse    _9parse
  3205.  
  3206.     zname    <okPrompt>    ; i*x -- i*x
  3207.     ctok    NEST        ; implementation
  3208.     ctok    DOKDOTQUOTE
  3209.     dd    okPrompt
  3210.     ctok    DEPTH
  3211.     ctok    DOT
  3212.     ctok    UNNEST
  3213.  
  3214.     nnamemanque    <..>    ; i*x --
  3215. fw_DOTDOT:
  3216.     ctok    NEST
  3217.     ctok    DEPTH
  3218.     literal    0
  3219.     compqdo    dotdot2
  3220. dotdot1:
  3221.     ctok    U_DOT
  3222.     comploop    dotdot1
  3223. dotdot2:
  3224.     ctok    UNNEST
  3225.  
  3226.     fname    <QUIT>        ; ( --) ( R: i*x --)
  3227.     ctok    NEST        ; CORE
  3228.     literal    ticktib
  3229.     ctok    TICK_TIB    ; reset input buffer
  3230.     ctok    STORE
  3231.     literal    FALSE
  3232.     ctok    BLK        ; Not BLOCK input
  3233.     ctok    STORE
  3234.     literal    FALSE
  3235.     ctok    SOURCE_ID    ; Indicate keyboard input
  3236.     ctok    STORE
  3237.     literal    FALSE
  3238.     ctok    NUMTIB        ; indicate that input stream is empty
  3239.     ctok    STORE
  3240.     literal    FALSE
  3241.     ctok    TO_IN        ; indicate that input stream is unparsed
  3242.     ctok    STORE
  3243.     literal    FALSE
  3244.     ctok    STATE        ; set STATE to interpret
  3245.     ctok    STORE
  3246.     literal    FALSE
  3247.     literal    inDefinition    ; we're not in the middle of a : or :NONAME
  3248.     ctok    STORE
  3249. _1quit:                ; this is a "begin"
  3250.     ctok    CR        ; ye olde CR each Forth QUIT
  3251.     literal    rpzero        ; zero the return stack
  3252.     ctok    FETCH
  3253.     ctok    RP_STORE    ; init the RP stack
  3254.     ctok    FIRSTCATCH    ; set up initial catch frame
  3255.     literal    FALSE
  3256.     literal    endq
  3257.     ctok    STORE        ; reset end-of-input var
  3258.     ctok    REFILL        ; get a line of input
  3259.     compif    _1quit        ; loop back if no input line
  3260.     ctok    INTERPRET    ; execute it
  3261.     ctok    STATE        ; check STATE
  3262.     ctok    FETCH
  3263.     ctok    ZEROEQ
  3264.     compif    _2quit
  3265.     ctok    okPrompt    ; say "ok " if interpreting
  3266. _2quit:  compelse    _1quit    ; and this is an "Again"
  3267.  
  3268.     fname    <SOURCE>    ; -- c-addr u
  3269.     ctok    NEST        ; CORE
  3270.     ctok    BLK
  3271.     ctok    FETCH
  3272.     ctok    QDUP
  3273.     compif    source1
  3274.     ctok    BLOCK
  3275.     literal    blockSize
  3276.     ctok    EXIT
  3277. source1:
  3278.     ctok    TIB
  3279.     ctok    NUMTIB
  3280.     ctok    FETCH
  3281.     ctok    UNNEST
  3282.     
  3283.     fnamemanque    <SOURCE-ID>    ; -- a-addr
  3284. fw_SOURCE_ID:
  3285.     ctok    DOCONST            ; CORE
  3286.     dd    var_srcid
  3287.  
  3288.     fname    <TIB>        ; -- c-addr
  3289.     ctok    NEST        ; CORE EXT
  3290.     ctok    TICK_TIB
  3291.     ctok    FETCH
  3292.     ctok    UNNEST
  3293.  
  3294. ; Can't use our name header macros with this one!
  3295.     linkme    nlinkptr
  3296.     countcell    4
  3297.     db    "'",0,'T',0,'I',0,'B',0    ; -- a-addr
  3298.     align    4            ; Not in Standard
  3299. fw_TICK_TIB:
  3300.     ctok    DOCONST    
  3301.     dd    var_tib
  3302.  
  3303.     fnamemanque    <#TIB>    ; -- c-addr
  3304. fw_NUMTIB:
  3305.     ctok    DOCONST        ; CORE EXT
  3306.     dd    var_numtib
  3307.  
  3308. ; Can't use our name header macros with this one!
  3309.     linkme    flinkptr
  3310.     countcell    3
  3311.     db    '>',0,'I',0,'N',0    ; -- a-addr
  3312.     align    4            ; CORE
  3313. fw_TO_IN:
  3314.     ctok    DOCONST
  3315.     dd    var_to_in
  3316.  
  3317.     fname    <REFILL>    ; -- flag
  3318.     ctok    NEST        ; CORE EXT
  3319.     ctok    SOURCE_ID    ; check source of input
  3320.     ctok    FETCH
  3321.     literal    -1
  3322.     ctok    EQUAL        ; if it's EVALUATE, exit FALSE
  3323.     compif    refill1
  3324.     ctok    FALSE
  3325.     ctok    EXIT
  3326. refill1:
  3327.     ctok    BLK
  3328.     ctok    FETCH        ; -- u
  3329.     ctok    QDUP        ; -- u u | o
  3330.     compif    refill2        ; we get input from the next BLOCK
  3331.     ctok    ONE_PLUS    ; -- u'
  3332.     ctok    DUP        ; -- u' u'
  3333.     ctok    BLK        ; -- u' u' a-addr
  3334.     ctok    STORE        ; -- u'
  3335.     ctok    FALSE        ; Reset interpreter values
  3336.     ctok    TO_IN
  3337.     ctok    STORE
  3338.     ctok    FALSE
  3339.     literal    endq
  3340.     ctok    STORE
  3341.     ctok    INVALIDBLOCK    ; -- flag, TRUE if invalid block number
  3342.     ctok    ZEROEQ        ; -- flag, correct sense for REFILL's return
  3343.     ctok    EXIT
  3344. refill2:            ; We get input from the terminal
  3345.     ctok    FALSE
  3346.     ctok    TO_IN
  3347.     ctok    STORE        ; >IN OFF
  3348.     ctok    FALSE
  3349.     literal    endq
  3350.     ctok    STORE        ; END? OFF
  3351.     ctok    TIB
  3352.     literal    tibsize
  3353.     ctok    ACCEPT        ; Get as many chars as console can return
  3354.     ctok    NUMTIB        ; and store to #TIB
  3355.     ctok    STORE
  3356.     ctok    TRUE
  3357.     ctok    UNNEST
  3358.  
  3359.     fname    <WORD>        ; ( char "ccc<char>" -- c-addr)
  3360.     ctok    NEST        ; CORE
  3361.     ctok    PPARSE        ; -- c-addr u
  3362.     literal    wordBuffer    ; -- c-addr u dest
  3363.     ctok    TWO_DUP        ; -- c-addr u dest u dest
  3364.     ctok    SWAP        ; -- src u dest dest u
  3365.     ctok    ONE_PLUS    ; -- src u dest dest u'        taking the count word into account
  3366.     ctok    CHARS        ; -- src u dest dest n
  3367.     ctok    PLUS        ; -- src u dest c-addr(past end-of-dest)
  3368.     ctok    BL        ; -- src u dest c-addr bl
  3369.     ctok    SWAP        ; -- src u dest bl c-addr
  3370.     ctok    C_STORE        ; -- src u dest         pad string with a blank
  3371.     ctok    PLACE        ; --                install string
  3372.     literal    wordBuffer    ; -- c-addr            return word buffer addr
  3373.     ctok    UNNEST
  3374.  
  3375. ; Can't use our name header macros with this one!
  3376.     linkme    flinkptr
  3377.     countcell    <1 or immedMask>
  3378.     db    '(',0    
  3379.     align    4        ; "ccc<)>" --
  3380. fw_PAREN:            ; CORE
  3381.     ctok    NEST
  3382.     charlit    ')'
  3383.     ctok    PARSE
  3384.     ctok    TWO_DROP
  3385.     ctok    UNNEST
  3386.  
  3387. ; Can't use our name header macros with this one!
  3388.     linkme    flinkptr
  3389.     countcell    <1 or immedMask>
  3390.     db    '\',0    
  3391.     align    4        ; "ccc<eol>" --
  3392. fw_BSLASH:
  3393.     ctok    NEST
  3394.     ctok    BLK
  3395.     ctok    FETCH        ; -- n
  3396.     compif    bslash2
  3397.     ctok    TO_IN
  3398.     ctok    FETCH        ; -- n
  3399.     literal    64
  3400.     ctok    MOD        ; -- mod
  3401.     ctok    QDUP
  3402.     compif    bslash1        ; -- n
  3403.     literal    64
  3404.     ctok    SWAP
  3405.     ctok    MINUS        ; -- diff
  3406.     ctok    TO_IN
  3407.     ctok    PL_STORE    ; --
  3408. bslash1:
  3409.     ctok    EXIT        ; --
  3410. bslash2:
  3411.     ctok    NUMTIB        ; -- a-addr
  3412.     ctok    FETCH        ; -- n
  3413.     ctok    TO_IN
  3414.     ctok    STORE        ; --
  3415.     ctok    UNNEST
  3416.  
  3417. ;--( Implementation Addressing Scheme )
  3418. ; In this terminology, "Code" is the user dictionary offset from register CP,
  3419. ; "Data" is the data space offset from register DP (the latter not to be confused with Forth variable DP).
  3420. ; The system dictionary resides in absolute address space.
  3421.  
  3422. ; Convert absolute address to reg DP relative offset.
  3423.     sname    <ABSTODATA>    ; abs-addr -- data-addr
  3424.     dd    abstodata    ; Implementation
  3425. abstodata:
  3426.     sub    DWORD PTR [esp],dp
  3427.     next
  3428.  
  3429. ; Convert reg DP relative offset to absolute address.
  3430.     sname    <DATATOABS>    ; data-addr -- abs-addr
  3431.     dd    datatoabs    ; Implementation
  3432. datatoabs:
  3433.     add    DWORD PTR [esp],dp
  3434.     next
  3435.  
  3436. ; Convert absolute address to reg CP relative offset.
  3437.     sname    <ABSTOCODE>    ; abs-addr -- code-addr
  3438.     dd    abstocode    ; Implementation
  3439. abstocode:
  3440.     sub    DWORD PTR [esp],cp
  3441.     next
  3442.  
  3443. ; Convert reg CP relative offset to absolute address.
  3444.     sname    <CODETOABS>    ; code-addr -- abs-addr
  3445.     dd    codetoabs    ; Implementation
  3446. codetoabs:
  3447.     add    DWORD PTR [esp],cp
  3448.     next
  3449.  
  3450. ; Convert reg CP relative code offset to reg DP relative data offset
  3451.     sname    <CODETODATA>    ; code-addr -- data-addr
  3452.     ctok    NEST        ; Implementation
  3453.     ctok    CODETOABS
  3454.     ctok    ABSTODATA
  3455.     ctok    UNNEST
  3456.  
  3457. ; Convert reg DP relative data offset to reg CP relative code offset
  3458.     sname    <DATATOCODE>    ; data-addr -- code-addr
  3459.     ctok    NEST        ; Implementation
  3460.     ctok    DATATOABS
  3461.     ctok    ABSTOCODE
  3462.     ctok    UNNEST
  3463.  
  3464. ; Convert an offset in the user dictionary to a user dict execution token
  3465.     zname    <MAKETOKEN>    ; code-offset -- user-xt
  3466.     ctok    NEST        ; Implementation detail
  3467.     literal    userdictmask
  3468.     ctok    OR
  3469.     ctok    UNNEST
  3470.  
  3471. ; Detect if a given token is from the user dictionary
  3472.     znamemanque    <USERTOKEN?>
  3473. fw_USERTOKENQ:            ; xt -- flag
  3474.     ctok    NEST
  3475.     literal    userdictmask
  3476.     ctok    AND
  3477.     ctok    ZEROEQ
  3478.     ctok    ZEROEQ
  3479.     ctok    UNNEST
  3480.  
  3481. ; Unmask a user dictionary token
  3482.     zname    <DETOKEN>    ; user-xt -- code-offset
  3483.     ctok    NEST
  3484.     literal    userdictmask
  3485.     ctok    INVERT
  3486.     ctok    AND
  3487.     ctok    UNNEST
  3488.  
  3489. ;--( Compiler )
  3490. ; Any compiler word with "xt" in the stack args presumes that a valid form of xt is present on the stack in that position.
  3491.  
  3492.     zname    <SAVEDEPTH>    ; i*x -- i*x
  3493.     ctok    NEST        ; Implementation
  3494.     ctok    SP_FETCH
  3495.     literal    cstack
  3496.     ctok    STORE
  3497.     ctok    UNNEST
  3498.  
  3499.     zname    <CHECKDEPTH>    ; j*x -- j*x [ 0 | n if stack has changed ]
  3500.     ctok    NEST        ; Implementation
  3501.     ctok    SP_FETCH
  3502.     literal    cstack
  3503.     ctok    FETCH
  3504.     ctok    MINUS
  3505.     ctok    UNNEST
  3506.  
  3507.     zname    <HEADER>    ; c-addr u --
  3508.     ctok    NEST        ; Implementation
  3509.     ctok    DP
  3510.     ctok    FETCH        ; -- c-addr u code-offset
  3511.     ctok    MAKETOKEN    ; -- c-addr u valid-link-token
  3512.     literal    last        ; -- c-addr u valid-link-token a-addr
  3513.     ctok    STORE        ; -- c-addr u             keep token for last link added to dictionary
  3514.     ctok    GET_CURRENT    ; -- c-addr u wid
  3515.     ctok    ABSTODATA    ; -- c-addr u a-addr-pointer
  3516.     ctok    FETCH        ; -- c-addr u a-addr-wordlist-data-body
  3517.     ctok    FETCH        ; -- c-addr u token
  3518.     ctok    COMPCOMMA    ; -- c-addr u             compile back-link to previous definiton in wl
  3519.     ctok    DUP        ; -- c-addr u u
  3520.     literal    16
  3521.     ctok    LSHIFT        ; -- c-addr u u<<16        because we are going to store two words as a dword
  3522.     literal    0FFFFH        ; -- c-addr u u 0ffff
  3523.     ctok    OR        ; -- c-addr u 0ffffuuuu
  3524.     ctok    COMPCOMMA    ; -- c-addr u
  3525.     ctok    DP
  3526.     ctok    FETCH        ; -- c-addr u code-offset
  3527.     ctok    CODETODATA    ; -- c-addr u a-addr
  3528.     ctok    SWAP        ; -- c-addr a-addr u
  3529.     ctok    CHARS        ; -- c-addr a-addr uchars
  3530.     ctok    DUP        ; -- c-addr a-addr ubytes ubytes
  3531.     ctok    TO_R        ; -- c-addr a-addr ubytes        R: -- ubytes
  3532.     ctok    MOVE        ; --                    R: -- ubytes
  3533.     ctok    R_FROM        ; -- ubytes                R: --
  3534.     ctok    DP
  3535.     ctok    FETCH        ; -- ubytes code-offset
  3536.     ctok    PLUS        ; -- n
  3537.     ctok    ALIGNED        ; -- n'
  3538.     ctok    DP        ; -- n a-addr
  3539.     ctok    STORE        ; --
  3540.     ctok    UNNEST
  3541.  
  3542.     zname    <LINKIT>    ; --
  3543.     ctok    NEST        ; Implementation
  3544.     literal    last        ; -- a-addr
  3545.     ctok    FETCH        ; -- ltok
  3546.     ctok    GET_CURRENT    ; -- ltok wid
  3547.     ctok    ABSTODATA    ; -- ltok a-addr-pointer-to-wordlist-databody
  3548.     ctok    FETCH        ; -- ltok a-addr-of-wordlist-databody
  3549.     ctok    STORE        ; --
  3550.     ctok    UNNEST
  3551.  
  3552. ; This one's why ";" doesn't reset the system variable "nonaming"
  3553.     fname    <IMMEDIATE>    ; --
  3554.     ctok    NEST        ; CORE
  3555.     literal    nonaming
  3556.     ctok    FETCH
  3557.     literal    -32        ; zero-length string THROW
  3558.     ctok    AND
  3559.     ctok    THROW        ; a :NONAME word can't be IMMEDIATE
  3560.     literal    last
  3561.     ctok    FETCH
  3562.     ctok    TOKENTODATA
  3563.     ctok    LINKTONAME
  3564.     ctok    DUP
  3565.     ctok    C_FETCH
  3566.     literal    immedMask
  3567.     ctok    OR
  3568.     ctok    SWAP
  3569.     ctok    C_STORE
  3570.     ctok    UNNEST
  3571.  
  3572. ; Can't use our name header macros with this one!
  3573.     linkme    flinkptr
  3574.     countcell    1
  3575.     db    ':',0    
  3576.     align    4        ; "name" --
  3577. fw_COLON:            ; CORE
  3578.     ctok    NEST
  3579.     literal    inDefinition
  3580.     ctok    FETCH
  3581.     compif    colon1
  3582.     literal    -29
  3583.     ctok    THROW        ; nested compilation
  3584. colon1: ctok    TRUE
  3585.     literal    inDefinition    ; we're in a : definition now, prevent nested compilation
  3586.     ctok    STORE
  3587.     ctok    BL
  3588.     ctok    WORD
  3589.     ctok    COUNT
  3590.     ctok    QDUP
  3591.     ctok    ZEROEQ
  3592.     compif    colonnzero
  3593.     literal    -16
  3594.     ctok    THROW
  3595. colonnzero:
  3596.     ctok    FALSE
  3597.     literal    nonaming
  3598.     ctok    STORE        ; this is not a :NONAME defintion
  3599.     ctok    HEADER
  3600.     compelse    noname1    ; continue on in :NONAME
  3601.  
  3602. ; Can't use our name header macros with this one!
  3603.     linkme    flinkptr
  3604.     countcell    7
  3605.     db    ':',0,'N',0,'O',0,'N',0,'A',0,'M',0,'E',0
  3606.     align    4        ; -- | xt (when nonaming)
  3607. fw_noname:            ; CORE EXT
  3608.     ctok    NEST
  3609.     ctok    TRUE
  3610.     literal    inDefinition
  3611.     ctok    FETCH
  3612.     compif    noname0
  3613.     literal    -29
  3614.     ctok    THROW        ; nested compilation
  3615. noname0:
  3616.     literal    inDefinition    ; we're in a : definition now, prevent nested compilation
  3617.     ctok    STORE
  3618.     ctok    TRUE
  3619.     literal    nonaming
  3620.     ctok    STORE        ; this is a :NONAME defintion
  3621.     ctok    DP
  3622.     ctok    FETCH
  3623.     ctok    MAKETOKEN
  3624.     literal last
  3625.     ctok    STORE        ; so semicolon knows what to put on the stack
  3626. noname1:            ; colon ":" jumps here
  3627.     ctok    SAVEDEPTH    ; save stack depth to be checked by ";"
  3628.     ctok    DOLIT
  3629.     ctok    NEST
  3630.     ctok    COMPCOMMA
  3631.     ctok    RBRACKET
  3632.     ctok    UNNEST
  3633.  
  3634.     zname    <STATEABORT>    ; --
  3635.     ctok    NEST        ; Implementation
  3636.     ctok    STATE
  3637.     ctok    FETCH
  3638.     ctok    ZEROEQ        ; state zero? we're interpreting
  3639.     literal    -14        ; Interpreting a compile-only word throw
  3640.     ctok    AND
  3641.     ctok    THROW
  3642.     ctok    UNNEST
  3643.  
  3644. ; Can't use our name header macros with this one!
  3645.     linkme    flinkptr
  3646.     countcell    <immedMask or 1>
  3647.     db    ';',0    
  3648.     align    4        ; -- | xt (when nonaming)
  3649. fw_SEMICOLON:            ; CORE
  3650.     ctok    NEST
  3651.     ctok    STATEABORT
  3652.     ctok    FALSE
  3653.     literal    inDefinition    ; we're now out of a : or :NONAME
  3654.     ctok    STORE
  3655.     ctok    DOLIT
  3656.     ctok    UNNEST
  3657.     ctok    COMPCOMMA
  3658.     ctok    LBRACKET
  3659.     ctok    CHECKDEPTH
  3660.     compif    semi_done
  3661.     literal    -52
  3662.     ctok    THROW
  3663.     ctok    EXIT
  3664. semi_done:
  3665.     literal    nonaming
  3666.     ctok    FETCH
  3667.     compif    semi_named
  3668.     literal    last        ; unnamed, get xt for last definition and leave on stack
  3669.     ctok    FETCH
  3670.     ctok    EXIT
  3671. semi_named:
  3672.     ctok    LINKIT        ; named, link in to compilation wordlist
  3673.     ctok    UNNEST
  3674.  
  3675.     fnamemanque    <]>    ; --
  3676. fw_RBRACKET:            ; CORE
  3677.     ctok    NEST
  3678.     ctok    TRUE
  3679.     ctok    STATE
  3680.     ctok    STORE
  3681.     ctok    UNNEST
  3682.  
  3683.     finamemanque    <[>    ; --
  3684. fw_LBRACKET:            ; CORE
  3685.     ctok    NEST
  3686.     ctok    STATEABORT
  3687.     ctok    FALSE
  3688.     ctok    STATE
  3689.     ctok    STORE
  3690.     ctok    UNNEST
  3691.  
  3692.     fname    <STATE>        ; -- a-addr
  3693.     ctok    DOCONST        ; CORE
  3694.     dd    var_state
  3695.  
  3696.     nname    <DP>        ; -- a-addr
  3697.     ctok    DOCONST        ; Not in Standard
  3698.     dd    dictp
  3699.  
  3700. ; Can't use our name header macros with this one!
  3701.     linkme    flinkptr
  3702.     countcell    8
  3703.     db    'C',0,'O',0,'M',0,'P',0,'I',0,'L',0,'E',0,',',0    
  3704.     align    4            ; xt --
  3705. fw_COMPCOMMA:                ; CORE EXT
  3706.     ctok    NEST
  3707.     ctok    DP            ; -- xt dp
  3708.     ctok    DUP            ; -- xt dp dp
  3709.     ctok    FETCH            ; -- xt dp @dp
  3710.     ctok    ALIGNED            ; -- xt dp @dp'
  3711.     ctok    ROT            ; -- dp @dp' xt
  3712.     ctok    OVER            ; -- dp @dp' xt @dp'
  3713.     ctok    CODETODATA        ; -- dp @dp' xt a-addr
  3714.     ctok    STORE            ; -- dp @dp'
  3715.     ctok    CELL_PLUS        ; -- dp @dp''
  3716.     ctok    SWAP            ; -- @dp'' dp(a-addr)
  3717.     ctok    STORE            ; --
  3718.     ctok    UNNEST
  3719.  
  3720.     finame    <RECURSE>    ; --
  3721.     ctok    NEST        ; CORE
  3722.     ctok    STATEABORT
  3723.     literal    last
  3724.     ctok    FETCH
  3725.     ctok    TOKENTODATA
  3726.     ctok    LINKTOEXE
  3727.     ctok    DATATOCODE
  3728.     ctok    MAKETOKEN
  3729.     ctok    COMPCOMMA
  3730.     ctok    UNNEST
  3731.  
  3732. ; Can't use our name header macros with this one!
  3733.     linkme    flinkptr
  3734.     countcell    5
  3735.     db    '>',0,'B',0,'O',0,'D',0,'Y',0
  3736.     align    4            ; xt -- a-addr
  3737. fw_TO_BODY:                ; CORE
  3738.     ctok    NEST
  3739.     ctok    TOKENTODATA        ; -- a-addr
  3740.     ctok    DUP            ; -- a-addr a-addr
  3741.     ctok    FETCH            ; -- a-addr xt2
  3742.     ctok    DUP            ; -- a-addr xt2 xt2
  3743.     ctok    DOLIT
  3744.     ctok    DOCONST            ; -- a-addr xt2 xt2 xt3
  3745.     ctok    EQUAL            ; -- a-addr xt2 flag
  3746.     ctok    SWAP            ; -- a-addr flag xt2
  3747.     ctok    DUP            ; -- a-addr flag xt2 xt2
  3748.     ctok    DOLIT
  3749.     ctok    DODOES            ; -- a-addr flag xt2 xt2 xt4
  3750.     ctok    EQUAL            ; -- a-addr flag1 xt2 flag2
  3751.     ctok    SWAP            ; -- a-addr flag1 flag2 xt2
  3752.     ctok    DOLIT
  3753.     ctok    DODEFER            ; -- a-addr flag1 flag2 xt2 xt5
  3754.     ctok    EQUAL            ; -- a-addr flag1 flag2 flag3
  3755.     ctok    OR            ; -- a-addr flag1 flag4
  3756.     ctok    OR            ; -- a-addr flag
  3757.     ctok    ZEROEQ            ; -- a-addr ~flag
  3758.     compif    to_body1
  3759.     literal    -31
  3760.     ctok    THROW
  3761. to_body1:
  3762.     ctok    CELL_PLUS        ; -- a-addr'
  3763.     ctok    FETCH            ; -- a-addr''
  3764.     ctok    UNNEST
  3765.  
  3766.     fname    <CREATE>    ; "name" --
  3767.     ctok    NEST        ; CORE
  3768.     ctok    ALIGN
  3769.     ctok    BL
  3770.     ctok    WORD
  3771.     ctok    COUNT
  3772.     ctok    QDUP
  3773.     ctok    ZEROEQ
  3774.     compif    create1
  3775.     literal    -16
  3776.     ctok    THROW
  3777. create1:
  3778.     ctok    HEADER
  3779.     ctok    DOLIT
  3780.     ctok    DOCONST
  3781.     ctok    COMPCOMMA
  3782.     ctok    HERE
  3783.     ctok    COMPCOMMA
  3784.     ctok    LINKIT
  3785.     ctok    UNNEST
  3786.  
  3787.     fname    <VARIABLE>    ; "name" --
  3788.     ctok    NEST        ; CORE
  3789.     ctok    CREATE
  3790.     literal    1
  3791.     ctok    CELLS
  3792.     ctok    ALLOT
  3793.     ctok    UNNEST
  3794.  
  3795.     fname    <CONSTANT>    ; x "name" --
  3796.     ctok    NEST        ; CORE
  3797.     ctok    CREATE
  3798.     ctok    DP
  3799.     ctok    FETCH
  3800.     ctok    CODETODATA
  3801.     literal    1
  3802.     ctok    CELLS
  3803.     ctok    MINUS
  3804.     ctok    STORE
  3805.     ctok    UNNEST
  3806.  
  3807.     zname    <MAKEDOES>    ; xt --
  3808.     ctok    NEST        ; Implementation
  3809.     ctok    DOLIT
  3810.     ctok    DODOES
  3811.     literal    last        ; Link token left by the execution of CREATE
  3812.     ctok    FETCH
  3813.     ctok    TOKENTODATA
  3814.     ctok    LINKTOEXE    ; Link token is now data address of execution vector
  3815.     ctok    STORE        ; Now execution vector of CREATEd word is overwritten with DODOES
  3816.     ctok    COMPCOMMA    ; compile the xt for the DOES> body
  3817.     ctok    UNNEST
  3818.  
  3819. ; Can't use our name header macros with this one!
  3820.     linkme    flinkptr
  3821.     countcell    <5 or immedMask>
  3822.     db    'D',0,'O',0,'E',0,'S',0,'>',0
  3823.     align    4            ; --
  3824. fw_DOES:                ; CORE
  3825.     ctok    NEST
  3826.     ctok    DOLIT
  3827.     ctok    DOLIT
  3828.     ctok    COMPCOMMA        ; we are laying down a literal
  3829.     ctok    DP
  3830.     ctok    FETCH
  3831.     literal    3
  3832.     ctok    CELLS
  3833.     ctok    PLUS            ; the literal is the dict pointer plus the cells laid down by DOES> ..
  3834.     ctok    COMPCOMMA        ; .. up to the code laid down in the DOES> body.
  3835.     ctok    DOLIT
  3836.     ctok    MAKETOKEN
  3837.     ctok    COMPCOMMA        ; Then MAKETOKEN has to be executed on that literal at DOES> time
  3838.     ctok    DOLIT
  3839.     ctok    MAKEDOES        ; Resultant xt is consumed by MAKEDOES
  3840.     ctok    COMPCOMMA
  3841.     ctok    DOLIT
  3842.     ctok    EXIT
  3843.     ctok    COMPCOMMA        ; Then we EXIT the CREATE .. DOES> definition but continue to compile
  3844.     ctok    UNNEST
  3845.  
  3846.     finame    <LITERAL>    ; x --
  3847.     ctok    NEST        ; CORE
  3848.     ctok    DOLIT
  3849.     ctok    DOLIT
  3850.     ctok    COMPCOMMA
  3851.     ctok    COMPCOMMA
  3852.     ctok    UNNEST
  3853.  
  3854.     finamemanque    <2LITERAL>    ; x x --
  3855. fw_TWO_LITERAL:            ; DOUBLE
  3856.     ctok    NEST
  3857.     ctok    DOLIT
  3858.     ctok    DODLIT
  3859.     ctok    COMPCOMMA
  3860.     ctok    COMPCOMMA
  3861.     ctok    COMPCOMMA
  3862.     ctok    UNNEST
  3863.  
  3864.     finame    <POSTPONE>    ; "name" --
  3865.     ctok    NEST        ; CORE
  3866.     ctok    STATEABORT
  3867.     ctok    BL
  3868.     ctok    WORD
  3869.     ctok    FIND
  3870.     ctok    DUP
  3871.     ctok    ZEROEQ
  3872.     compif    postpone1
  3873.     ctok    UNFOUND
  3874. postpone1:
  3875.     ctok    DOLIT        ; first of all, compile this code here ..
  3876.     ctok    STATEABORT    ; ... since ..
  3877.     ctok    COMPCOMMA    ; ... the POSTPONEd construct should THROW -14 if encountered interpretively.
  3878.     ctok    ZEROLT        ; -1 is non-IMMEDIATE
  3879.     compif    postpone2
  3880.     ctok    LITERAL
  3881.     ctok    DOLIT
  3882.     ctok    COMPCOMMA
  3883.     ctok    COMPCOMMA
  3884.     ctok    EXIT
  3885. postpone2:            ; 1 is IMMEDIATE
  3886.     ctok    COMPCOMMA
  3887.     ctok    UNNEST
  3888.  
  3889. ;--( Branches )
  3890.  
  3891.     zname    <UNRESOLVED>    ; --
  3892.     ctok    NEST        ; Implementation
  3893.     literal    -22
  3894.     ctok    THROW
  3895.  
  3896.     finame    <IF>            ; -- orig
  3897.     ctok    NEST            ; CORE
  3898.     ctok    STATEABORT
  3899.     ctok    DOLIT
  3900.     ctok    DOIF            ; -- xt
  3901.     ctok    COMPCOMMA        ; --
  3902.     ctok    DP
  3903.     ctok    FETCH            ; -- orig
  3904.     ctok    DOLIT
  3905.     ctok    UNRESOLVED        ; -- orig xt
  3906.     ctok    COMPCOMMA        ; -- orig
  3907.     ctok    UNNEST
  3908.  
  3909.     finame    <ELSE>            ; orig1 -- orig2
  3910.     ctok    NEST            ; CORE
  3911.     ctok    STATEABORT
  3912.     ctok    DOLIT
  3913.     ctok    DOELSE            ; -- o1 xt
  3914.     ctok    COMPCOMMA        ; -- o1
  3915.     ctok    DP
  3916.     ctok    FETCH            ; -- o1 o2
  3917.     ctok    SWAP            ; -- o2 o1
  3918.     ctok    DOLIT
  3919.     ctok    UNRESOLVED        ; -- o2 o1 xt    
  3920.     ctok    COMPCOMMA        ; -- o2 o1
  3921.     ctok    DP
  3922.     ctok    FETCH            ; -- o2 o1 resolution
  3923.     ctok    MAKETOKEN        ; -- o2 o1 xt
  3924.     ctok    SWAP            ; -- o2 xt o1
  3925.     ctok    CODETODATA        ; -- o2 xt a-addr
  3926.     ctok    STORE            ; -- o2
  3927.     ctok    UNNEST
  3928.  
  3929.     finame    <THEN>            ; orig --
  3930.     ctok    NEST            ; CORE
  3931.     ctok    STATEABORT
  3932.     ctok    DP
  3933.     ctok    FETCH            ; -- orig resolution
  3934.     ctok    MAKETOKEN        ; -- orig xt
  3935.     ctok    SWAP            ; -- xt orig
  3936.     ctok    CODETODATA        ; -- xt a-addr
  3937.     ctok    STORE            ; --
  3938.     ctok    UNNEST
  3939.  
  3940.     finame    <BEGIN>            ; -- dest
  3941.     ctok    NEST            ; CORE
  3942.     ctok    STATEABORT
  3943.     ctok    DP
  3944.     ctok    FETCH            ; -- dest
  3945.     ctok    UNNEST
  3946.  
  3947.     finame    <UNTIL>            ; dest --
  3948.     ctok    NEST            ; CORE
  3949.     ctok    STATEABORT        
  3950.     ctok    DOLIT
  3951.     ctok    DOUNTIL            ; -- dest xt
  3952.     ctok    COMPCOMMA        ; -- dest
  3953.     ctok    MAKETOKEN        ; -- xt
  3954.     ctok    COMPCOMMA        ; --
  3955.     ctok    UNNEST
  3956.  
  3957.     finame    <WHILE>            ; dest -- orig dest
  3958.     ctok    NEST            ; CORE
  3959.     ctok    STATEABORT        
  3960.     ctok    DOLIT
  3961.     ctok    DOIF            ; -- dest xt
  3962.     ctok    COMPCOMMA        ; -- dest
  3963.     ctok    DP
  3964.     ctok    FETCH            ; -- dest orig
  3965.     ctok    SWAP            ; -- orig dest
  3966.     ctok    DOLIT
  3967.     ctok    UNRESOLVED        ; -- orig dest xt
  3968.     ctok    COMPCOMMA        ; -- orig dest
  3969.     ctok    UNNEST
  3970.     
  3971.     finame    <REPEAT>        ; orig dest --
  3972.     ctok    NEST            ; CORE
  3973.     ctok    STATEABORT
  3974.     ctok    DOLIT
  3975.     ctok    DOELSE            ; -- o d xt
  3976.     ctok    COMPCOMMA        ; -- o d
  3977.     ctok    MAKETOKEN        ; -- o xt
  3978.     ctok    COMPCOMMA        ; -- o
  3979.     ctok    DP
  3980.     ctok    FETCH            ; -- o resolution
  3981.     ctok    MAKETOKEN        ; -- o xt
  3982.     ctok    SWAP            ; -- xt orig
  3983.     ctok    CODETODATA        ; -- xt a-addr
  3984.     ctok    STORE            ; --
  3985.     ctok    UNNEST
  3986.  
  3987.     finame    <AGAIN>            ; dest --
  3988.     ctok    NEST            ; CORE EXT
  3989.     ctok    STATEABORT
  3990.     ctok    DOLIT
  3991.     ctok    DOELSE            ; -- d xt
  3992.     ctok    COMPCOMMA        ; -- d
  3993.     ctok    MAKETOKEN        ; -- xt
  3994.     ctok    COMPCOMMA        ; --
  3995.     ctok    UNNEST
  3996.  
  3997.     finame    <DO>            ; -- do-dest
  3998.     ctok    NEST            ; CORE
  3999.     ctok    STATEABORT
  4000.     ctok    DOLIT
  4001.     ctok    DODO            ; -- xt
  4002.     ctok    COMPCOMMA        ; --
  4003.     ctok    DP
  4004.     ctok    FETCH            ; -- do-dest
  4005.     ctok    DOLIT
  4006.     ctok    UNRESOLVED        ; -- do-dest xt
  4007.     ctok    COMPCOMMA        ; -- do-dest
  4008.     ctok    UNNEST
  4009.  
  4010.     finamemanque    <?DO>        ; -- dest
  4011. fw_QDO:    ctok    NEST            ; CORE
  4012.     ctok    STATEABORT
  4013.     ctok    DOLIT
  4014.     ctok    DOQDO            ; -- xt
  4015.     ctok    COMPCOMMA        ; --
  4016.     ctok    DP
  4017.     ctok    FETCH            ; -- do-dest
  4018.     ctok    DOLIT
  4019.     ctok    UNRESOLVED        ; -- do-dest xt
  4020.     ctok    COMPCOMMA        ; -- do-dest
  4021.     ctok    UNNEST
  4022.  
  4023.     finame    <LOOP>            ; dest --
  4024.     ctok    NEST            ; CORE
  4025.     ctok    STATEABORT
  4026.     ctok    DOLIT
  4027.     ctok    DOLOOP            ; -- dest xt
  4028.     ctok    COMPCOMMA        ; -- dest
  4029.     ctok    DUP            ; -- dest dest
  4030.     ctok    CELL_PLUS        ; -- dest dest'        so that it points beyond UNRESOLVED
  4031.     ctok    MAKETOKEN        ; -- dest xt
  4032.     ctok    COMPCOMMA        ; -- dest
  4033.     ctok    DP
  4034.     ctok    FETCH            ; -- dest resolution
  4035.     ctok    MAKETOKEN        ; -- dest xt
  4036.     ctok    SWAP            ; -- xt dest
  4037.     ctok    CODETODATA        ; -- xt a-addr
  4038.     ctok    STORE            ; --
  4039.     ctok    UNNEST
  4040.  
  4041.     finamemanque    <+LOOP>        ; --
  4042. fw_PLUSLOOP:
  4043.     ctok    NEST            ; CORE
  4044.     ctok    STATEABORT
  4045.     ctok    DOLIT
  4046.     ctok    DOPLUSLOOP        ; -- dest xt
  4047.     ctok    COMPCOMMA        ; -- dest
  4048.     ctok    DUP            ; -- dest dest
  4049.     ctok    CELL_PLUS        ; -- dest dest'        so that it points beyond UNRESOLVED
  4050.     ctok    MAKETOKEN        ; -- dest xt
  4051.     ctok    COMPCOMMA        ; -- dest
  4052.     ctok    DP
  4053.     ctok    FETCH            ; -- dest resolution
  4054.     ctok    MAKETOKEN        ; -- dest xt
  4055.     ctok    SWAP            ; -- xt dest
  4056.     ctok    CODETODATA        ; -- xt a-addr
  4057.     ctok    STORE            ; --
  4058.     ctok    UNNEST
  4059.  
  4060.     fname    <I>            ; -- n|u
  4061.     docode                ; CORE
  4062.     mov    eax,[rp]        ; Calculate current loop index
  4063.     add    eax,cell[rp]
  4064.     push    eax
  4065.     next
  4066.  
  4067.     fname    <J>            ; -- n|u
  4068.     docode                ; CORE
  4069.     mov    eax,(3*cell)[rp]    ; Calculate next outermost loop index
  4070.     add    eax,(4*cell)[rp]
  4071.     push    eax
  4072.     next
  4073.  
  4074.     fname    <LEAVE>
  4075.     docode                ; --    R: loop-sys --
  4076.     poprp                ; CORE
  4077.     poprp
  4078.     poprpto    ip
  4079.     next
  4080.  
  4081.     fname    <UNLOOP>        ; --    R: loop-sys --
  4082.     docode                ; CORE
  4083.     poprp
  4084.     poprp
  4085.     poprp
  4086.     next
  4087.  
  4088. ;--( Exception Handling )
  4089.  
  4090.     fname    <ABORT>        ; --
  4091.     ctok    NEST        ; CORE
  4092.     ctok    TRUE
  4093.     ctok    THROW        ; no unnest needed!
  4094.  
  4095. ; Can't use our name header macros with this one!
  4096.     linkme    flinkptr
  4097.     countcell    <6 or immedMask>
  4098.     db    'A',0,'B',0,'O',0,'R',0,'T',0,'"',0    ; ccc<"> --
  4099.     align    4                    ; CORE
  4100. fw_ABORT_QUOTE:
  4101.     ctok    NEST
  4102.     ctok    STATEABORT
  4103.     ctok    DOLIT
  4104.     ctok    DOIF            ; -- xt
  4105.     ctok    COMPCOMMA        ; --
  4106.     ctok    DP
  4107.     ctok    FETCH            ; -- orig
  4108.     ctok    DOLIT
  4109.     ctok    UNRESOLVED        ; -- orig xt
  4110.     ctok    COMPCOMMA        ; -- orig
  4111.     literal    -2
  4112.     ctok    LITERAL
  4113.     ctok    DP
  4114.     ctok    FETCH
  4115.     ctok    S_QUOTE
  4116.     ctok    CODETODATA
  4117.     ctok    DOLIT
  4118.     ctok    THROW
  4119.     ctok    SWAP
  4120.     ctok    STORE            ; overwrite the S" execution engine
  4121.     ctok    DP
  4122.     ctok    FETCH            ; -- orig resolution
  4123.     ctok    MAKETOKEN        ; -- orig xt
  4124.     ctok    SWAP            ; -- xt orig
  4125.     ctok    CODETODATA        ; -- xt a-addr
  4126.     ctok    STORE            ; --
  4127.     ctok    UNNEST
  4128.  
  4129.     fname    <CATCH>            ; i*x xt -- j*x 0 | i*x n)
  4130.     dd    catch            ; EXCEPTION
  4131. catch:    pop    wp            ; execution token
  4132.     fetch    edx,lastCatch        ; save previous catch pointer
  4133.     pushrp    edx            ; (1)
  4134.     pushrp    esp            ; (2) save stack pointer
  4135.     fetch    edx,var_tib        ; save buffer address
  4136.     pushrp    edx            ; (3)
  4137.     fetch    edx,var_numtib        ; save number of chars in input buffer
  4138.     pushrp    edx            ; (4)
  4139.     fetch    edx,var_to_in        ; save index into input buffer
  4140.     pushrp    edx            ; (5)
  4141.     fetch    edx,var_srcid        ; save source id
  4142.     pushrp    edx            ; (6)
  4143.     fetch    edx,var_blk        ; save BLK
  4144.     pushrp    edx            ; (7)
  4145.     pushrp    ip            ; (8) save interpretive pointer
  4146.     store    lastCatch,rp        ; put pointer to this frame in lastCatch variable
  4147.     mov    ecx,OFFSET FLAT:uncatch    ; routine to recover
  4148.     mov    ip,ecx
  4149.     innext                ; eax (the wp) already has the token to execute
  4150.     align    cell
  4151. uncatch:                ; we only end up here if no THROW intervenes
  4152.     docode                ; as if it was a cell in a colon definition pointing to ...
  4153.     docode                ; ... a definition which started here ...
  4154.     fetch    rp,lastCatch        ; restore return pointer from lastCatch, points to frame
  4155.     poprpto    ip            ; (8) restore IP that was stashed by CATCH
  4156.     poprp                ; (7) discard BLK
  4157.     poprp                ; (6) discard SOURCE-ID
  4158.     poprp                ; (5) discard >IN
  4159.     poprp                ; (4) discard #TIB
  4160.     poprp                ; (3) discard 'TIB
  4161.     poprp                ; (2) discard DSP
  4162.     poprpto    eax            ; (1) lastCatch
  4163.     store    lastCatch,eax
  4164.     xor    eax,eax
  4165.     push    eax            ; 0 return says all is well
  4166.     next
  4167.  
  4168.     fname    <THROW>            ; k*x n -- k*x | i*x n
  4169.     docode                ; EXCEPTION
  4170.     pop    edx            ; check arg
  4171.     and    edx,edx
  4172.     jne    throw1            ; zero? continue harmlessly
  4173.     next
  4174. throw1:                    ; arg was non-zero
  4175.     fetch    rp,lastCatch        ; set return stack back to where it was
  4176.     store    lastCaught,ip        ; save IP pointing to cell following the THROW
  4177.     poprpto    ip            ; (8) restore IP that was stashed by CATCH
  4178.     poprpto    eax            ; (7)
  4179.     store    var_blk,eax        ; restore BLK
  4180.     poprpto    eax            ; (6)
  4181.     store    var_srcid,eax        ; restore SOURCE-ID
  4182.     poprpto    eax            ; (5))
  4183.     store    var_to_in,eax        ; restore >IN
  4184.     poprpto    eax            ; (4)
  4185.     store    var_numtib,eax        ; restore #TIB
  4186.     poprpto    eax            ; (3)
  4187.     store    var_tib,eax        ; restore 'TIB
  4188.     poprpto    esp            ; (2) restore DSP
  4189.     poprpto    eax            ; (1)
  4190.     store    lastCatch,eax        ; restore lastCatch
  4191.     push    edx            ; the throw code
  4192.     next
  4193.  
  4194.     zname    <FIRSTCATCH>        ; --    R: -- catch-sys
  4195.     docode                ; Implementation
  4196.     xor    edx,edx
  4197.     pushrp    edx            ; there is no previous catch to push in this case
  4198.     pushrp    esp            ; save stack pointer
  4199.     fetch    edx,var_tib        ; save buffer address
  4200.     pushrp    edx
  4201.     fetch    edx,var_numtib        ; save number of chars in input buffer
  4202.     pushrp    edx
  4203.     fetch    edx,var_to_in        ; save number of chars in input buffer
  4204.     pushrp    edx
  4205.     fetch    edx,var_srcid        ; save source id
  4206.     pushrp    edx
  4207.     fetch    edx,var_blk        ; save BLK
  4208.     pushrp    edx
  4209.     mov    eax,OFFSET FLAT:fw_CATCHFIRSTCATCH+cell
  4210.     pushrp    eax            ; the CATCH of last resort!
  4211.     store    lastCatch,rp        ; put pointer to this frame in lastCatch variable
  4212.     next                ; onwards!
  4213.  
  4214.     zname    <CATCHFIRSTCATCH>    ; --
  4215.     ctok    NEST            ; Implementation
  4216.     ctok    DUP
  4217.     literal    -2            ; The ABORT" throw
  4218.     ctok    EQUAL
  4219.     compif    catchfirst1
  4220.     literal    lastCaught        ; Get IP which is pointing to pointer to string
  4221.     ctok    FETCH            ; IP
  4222.     ctok    TOKENTODATA    
  4223.     ctok    FETCH            ; data address of counted string    
  4224.     ctok    COUNT
  4225.     ctok    TYPE
  4226.     compelse    catchabort    ; fall thru into the tail of ABORT throw
  4227. catchfirst1:
  4228.     ctok    DUP
  4229.     literal    -1            ; The ABORT throw
  4230.     ctok    EQUAL
  4231.     compif    catchfirst4
  4232. catchabort:
  4233.     ctok    SP0
  4234.     ctok    FETCH
  4235.     ctok    SP_STORE
  4236.     ctok    FIRSTCATCH        ; if we hit the LASTCATCH frame, SP=SP0, RP=RP0, etc, just rebuild LASTCATCH
  4237.     ctok    QUIT            ; just QUIT
  4238. catchfirst4:
  4239.     ctok    DUP
  4240.     literal    -4
  4241.     ctok    EQUAL
  4242.     compif    catchfirst13
  4243.     ctok    DOKDOTQUOTE        ; stack underflow abort
  4244.     dd    stackUnderMsg
  4245.     compelse    catchabort    ; exit via an ABORT
  4246. catchfirst13:
  4247.     ctok    DUP
  4248.     literal    -13
  4249.     ctok    EQUAL
  4250.     compif    catchfirst14
  4251.     literal    wordBuffer
  4252.     ctok    COUNT
  4253.     ctok    TYPE
  4254.     ctok    SPACE
  4255.     charlit '?'
  4256.     ctok    EMIT
  4257.     ctok    SPACE
  4258.     ctok    DOKDOTQUOTE        ; undefined word abort
  4259.     dd    undefinedMsg
  4260.     compelse    catchabort    ; exit via an ABORT
  4261. catchfirst14:
  4262.     ctok    DUP
  4263.     literal    -14
  4264.     ctok    EQUAL
  4265.     compif    catchfirst16
  4266.     ctok    DOKDOTQUOTE        ; compile-only abort
  4267.     dd    compOnlyMsg
  4268.     compelse    catchabort    ; exit via an ABORT
  4269. catchfirst16:
  4270.     ctok    DUP
  4271.     literal    -16
  4272.     ctok    EQUAL
  4273.     compif    catchfirst22
  4274.     ctok    DOKDOTQUOTE        ; zero-length name string abort
  4275.     dd    zeroStringMsg
  4276.     compelse    catchabort    ; exit via an ABORT
  4277. catchfirst22:
  4278.     ctok    DUP
  4279.     literal    -22
  4280.     ctok    EQUAL
  4281.     compif    catchfirst29
  4282.     ctok    DOKDOTQUOTE        ; control structure abort
  4283.     dd    conStructMsg
  4284.     compelse    catchabort    ; exit via an ABORT
  4285. catchfirst29:
  4286.     ctok    DUP
  4287.     literal    -29
  4288.     ctok    EQUAL
  4289.     compif    catchfirst31
  4290.     ctok    FALSE
  4291.     literal    inDefinition        ; reset internal var indicating : or :NONAME in progress
  4292.     ctok    STORE
  4293.     ctok    DOKDOTQUOTE        ; >BODY on non-CREATE word
  4294.     dd    compNestMsg
  4295.     compelse    catchabort    ; exit via an ABORT
  4296. catchfirst31:
  4297.     ctok    DUP
  4298.     literal    -31
  4299.     ctok    EQUAL
  4300.     compif    catchfirst33
  4301.     ctok    DOKDOTQUOTE        ; >BODY on non-CREATE word
  4302.     dd    toBodyMsg
  4303.     compelse    catchabort    ; exit via an ABORT
  4304. catchfirst33:
  4305.     ctok    DUP
  4306.     literal    -33
  4307.     ctok    EQUAL
  4308.     compif    catchfirst34
  4309.     ctok    DOKDOTQUOTE        ; BLOCK read error
  4310.     dd    blockReadMsg
  4311.     compelse    catchabort    ; exit via an ABORT
  4312. catchfirst34:
  4313.     ctok    DUP
  4314.     literal    -34
  4315.     ctok    EQUAL
  4316.     compif    catchfirst35
  4317.     ctok    DOKDOTQUOTE        ; BLOCK write error
  4318.     dd    blockWriteMsg
  4319.     compelse    catchabort    ; exit via an ABORT
  4320. catchfirst35:
  4321.     ctok    DUP
  4322.     literal    -35
  4323.     ctok    EQUAL
  4324.     compif    catchfirst37
  4325.     ctok    DOKDOTQUOTE        ; BLOCK number error
  4326.     dd    blockNumMsg
  4327.     compelse    catchabort    ; exit via an ABORT
  4328. catchfirst37:
  4329.     ctok    DUP
  4330.     literal    -37
  4331.     ctok    EQUAL
  4332.     compif    catchfirst49
  4333.     ctok    LastError
  4334.     ctok    FETCH            ; Error should be in LastError if we reach this point
  4335.     ctok    DOKDOTQUOTE        ; File I/O exception
  4336.     dd    fileIOMsg        ; this message needs a trailing space!
  4337.     ctok    U_DOT            ; Display
  4338.     compelse    catchabort    ; exit via an ABORT
  4339. catchfirst49:
  4340.     ctok    DUP
  4341.     literal    -49            ; search order overflow THROW
  4342.     ctok    EQUAL
  4343.     compif    catchfirst50
  4344.     ctok    DOKDOTQUOTE
  4345.     dd    srchOverMsg
  4346.     compelse    catchabort    ; exit via an ABORT
  4347. catchfirst50:
  4348.     ctok    DUP
  4349.     literal    -50            ; search order underflow THROW
  4350.     ctok    EQUAL
  4351.     compif    catchfirst52
  4352.     ctok    DOKDOTQUOTE
  4353.     dd    srchUnderMsg
  4354.     compelse    catchabort    ; exit via an ABORT
  4355. catchfirst52:
  4356.     ctok    DUP
  4357.     literal    -52
  4358.     ctok    EQUAL
  4359.     compif    catchfirst56
  4360.     ctok    DOKDOTQUOTE
  4361.     dd    cStackMsg        ; control flow stack changed
  4362.     compelse    catchabort    ; exit via ABORT
  4363. catchfirst56:
  4364.     ctok    DUP
  4365.     literal    -56
  4366.     ctok    EQUAL
  4367.     compif    catchall
  4368.     ctok    DROP            ; drop the -56
  4369.     ctok    FIRSTCATCH        ; if we hit the LASTCATCH frame, SP=SP0, RP=RP0, etc, just rebuild LASTCATCH
  4370.     ctok    QUIT            ; just QUIT
  4371. catchall:                ; the catch-all case for THROWs outside those we have handled
  4372.     literal    throwMsg
  4373.     ctok    ABSTODATA
  4374.     literal    throwMsgLen
  4375.     ctok    TYPE
  4376.     ctok    DOT
  4377.     charlit    '@'
  4378.     ctok    EMIT
  4379.     ctok    SPACE
  4380.     literal    lastCaught
  4381.     ctok    FETCH
  4382.     literal    cell
  4383.     ctok    MINUS
  4384.     ctok    DOT
  4385.     ctok    FIRSTCATCH        ; if we hit the LASTCATCH frame, SP=SP0, RP=RP0, etc, just rebuild LASTCATCH
  4386.     ctok    QUIT
  4387.     ctok    UNNEST
  4388.  
  4389. ;--( Tools & Utilities )
  4390.  
  4391.     nname    <NOOP>        ; --
  4392.     docode            ; Doesn't appear in Standard
  4393.     nop
  4394.     next
  4395.  
  4396.     zname    <DUMPLINE>    ; a-addr1 -- a-addr2
  4397.     ctok    NEST
  4398.     ctok    DUP
  4399.     ctok    DUP        ; -- a-addr1 a-addr1
  4400.     ctok    FALSE
  4401.     ctok    LSHARP        ; -- a-addr1 ud
  4402.     literal    8
  4403.     ctok    FALSE
  4404.     compdo    dumpline2
  4405. dumpline1:
  4406.     ctok    SHARP        ; -- a-addr1 ud'
  4407.     comploop    dumpline1
  4408. dumpline2:
  4409.     ctok    SHARPR
  4410.     ctok    TYPE        ; -- a-addr1            print line address
  4411.     ctok    SPACE
  4412.     literal    8
  4413.     literal    0
  4414.     compdo    dumpline4
  4415. dumpline3:            ; -- addr addr
  4416.     ctok    COUNT        ; -- addr addr' char
  4417.     ctok    FALSE
  4418.     ctok    LSHARP
  4419.     ctok    SHARP
  4420.     ctok    SHARP
  4421.     ctok    SHARP
  4422.     ctok    SHARP
  4423.     ctok    SHARPR
  4424.     ctok    TYPE        ; -- addr addr'            print two bytes as a word
  4425.     ctok    SPACE
  4426.     comploop    dumpline3
  4427. dumpline4:
  4428.     ctok    DROP        ; -- addr
  4429.     literal    8
  4430.     literal    0
  4431.     compdo    dumpline6
  4432. dumpline5:
  4433.     ctok    COUNT
  4434.     literal    0FFh
  4435.     ctok    AND
  4436.     ctok    DUP
  4437.     literal    01fH        ; -- addr' char char 01fh
  4438.     ctok    GREATER
  4439.     compif    dumplinenochar
  4440.     ctok    EMIT
  4441.     compelse    dumplinez
  4442. dumplinenochar:
  4443.     ctok    DROP
  4444.     charlit    '.'
  4445.     ctok    EMIT
  4446. dumplinez:
  4447.     comploop    dumpline5
  4448. dumpline6:
  4449.     ctok    UNNEST        ; -- addr'
  4450.  
  4451.     fname    <DUMP>        ; addr u --
  4452.     ctok    NEST        ; TOOLKIT
  4453.     ctok    BASE        ; -- addr u a-addr
  4454.     ctok    FETCH        ; -- addr u n
  4455.     ctok    TO_R        ; -- addr u                    R: -- base
  4456.     ctok    HEX
  4457.     ctok    CR
  4458.     literal    dumpHdr        ; print a header here
  4459.     ctok    ABSTODATA
  4460.     ctok    COUNT
  4461.     ctok    TYPE        ; -- addr u                    R: -- base
  4462.     ctok    CR
  4463.     ctok    SWAP        ; -- u addr
  4464.     ctok    FALSE        ; -- u addr 0
  4465.     literal    16        ; Now align the dump region
  4466.     ctok    UMSLMOD        ; -- u1 u2r addr/8
  4467.     ctok    SWAP        ; -- u addr/8 u2r
  4468.     ctok    TO_R        ; -- u addr/8                R: -- u2r
  4469.     literal    16
  4470.     ctok    UMSTAR        ; -- u addr' 0                R: -- u2r
  4471.     ctok    DROP        ; -- u addr'                R: -- u2r
  4472.     ctok    SWAP        ; -- addr u                R: -- u2r
  4473.     ctok    FALSE        ; -- addr u 0                R: -- u2r
  4474.     literal    16
  4475.     ctok    UMSLMOD        ; -- addr u1r u2q                R: -- u2r
  4476.     ctok    SWAP        ; -- addr u2q u1r                R: -- u2r
  4477.     ctok    ZERONE        ; -- addr u/16 [-1 | 0]                R: -- u2r
  4478.     ctok    NEGATE        ; -- addr u/16 [1 | 0]                R: -- u2r
  4479.     ctok    PLUS        ; -- addr u(number of iterations)        R: -- u2r
  4480.     ctok    R_FROM        ; -- addr u/16 u2r                R: --
  4481.     ctok    ZERONE        ; -- addr u/16  [1|0] [-1 | 0]
  4482.     ctok    NEGATE        ; -- addr u/16  [1|0] [1 | 0]
  4483.     ctok    PLUS        ; -- addr u(number of iterations)    ; add line if bytes modded
  4484.     ctok    FALSE        ; -- addr u/16 0
  4485.     compdo    dump3        ; dump that many lines
  4486. dump1:    ctok    DUMPLINE    ; -- addr'
  4487.     ctok    CR        ; -- addr'
  4488.     ctok    KEY_Q        ; -- addr' flag, has user punched for pause or quick quit?
  4489.     compif    dumpcontinue    ; -- addr', user hasn't punched for pause or quick quit
  4490.     ctok    KEY        ; -- addr' char
  4491.     ctok    BL        ; -- addr' c1 c2
  4492.     ctok    EQUAL        ; -- addr' flag, was it a space bar?
  4493.     compif    dump2        ; -- addr', if not, it's a quit, hit a LEAVE below
  4494.     ctok    KEY        ; -- addr' char, space bar, we wait for user to punch again
  4495.     ctok    BL        ; -- addr' c1 c2
  4496.     ctok    EQUAL        ; -- addr' flag, if it's a space bar, resume
  4497.     compif    dump2        ; -- addr', but if it's anything else, quit
  4498.     compelse    dumpcontinue    ; -- addr, twas a space bar, continue
  4499. dump2:
  4500.     ctok    LEAVE        ; -- addr
  4501. dumpcontinue:
  4502.     comploop    dump1
  4503. dump3:                ; -- addr            R: -- +n
  4504.     ctok    DROP        ; --
  4505.     ctok    R_FROM        ; -- +n                R: --
  4506.     ctok    BASE        ; -- +n a-addr
  4507.     ctok    STORE        ; --
  4508.     ctok    UNNEST
  4509.  
  4510.     fname    <BYE>        ; --
  4511.     dd    byebye        ; TOOLKIT EXT
  4512. byebye:                ; exit program
  4513.     fetch    ebp,ntConEBP
  4514.     fetch    esp,ntConESP
  4515.     fetch    eax,memHandle
  4516.     INVOKE    LocalFree, eax
  4517.     INVOKE    WriteConsoleW, [dp+stdErr], OFFSET FLAT:byeMsg, byeMsgLen, OFFSET FLAT:numWritten,0
  4518.     pop    edi
  4519.     pop    esi
  4520.     pop    ebx
  4521.     leave
  4522.     INVOKE    ExitProcess, 0
  4523.  
  4524.     fnamemanque    <AT-XY>            ; u1 u2 --
  4525. fw_AT_XY:                    ; FACILITY
  4526.     docode
  4527.     pop    eax                ; y
  4528.     pop    edx                ; x
  4529.     shl    eax,16
  4530.     mov    ax,dx                ; compose COORD wherein Y is higher in mem than X
  4531.     INVOKE    SetConsoleCursorPosition, DWORD PTR stdOut[dp], eax
  4532.     and    eax,eax                ; success is "C" TRUE
  4533. ;    je    at_xy1                ; if failure, we'll do some more work
  4534.     mov    DWORD PTR lastError[dp],-1    ; success, set lastErr
  4535.     next                    ; success, exit
  4536. at_xy1:    jmp    doLastErr            ; return to NEXT via doLastErr
  4537.     
  4538.     fname    <PAGE>                ; --
  4539.     docode                    ; FACILITY
  4540.     mov    eax,20H                ; character to fill with
  4541.     mov    edx,32767            ; !!!***!!! HACK HACK HACK we have to calculate this correctly
  4542.     xor    ecx,ecx                ; Coord for fill, i.e., "0@0"
  4543.     INVOKE    FillConsoleOutputCharacterW, DWORD PTR stdOut[dp], eax, edx, ecx, OFFSET FLAT:numWritten
  4544.     and    eax,eax                ; success is "C" TRUE
  4545. ;    je    at_xy1                ; failure, exit re-using code above in AT-XY
  4546.     xor    eax,eax                ; make a "0@0" Coord for next call
  4547.     INVOKE    SetConsoleCursorPosition, DWORD PTR stdOut[dp], eax
  4548.     and    eax,eax                ; success is "C" TRUE
  4549. ;    je    at_xy1                ; failure, exit re-using code above in AT-XY
  4550.     mov    DWORD PTR lastError[dp],-1    ; success, set lastErr
  4551.     next
  4552.  
  4553.     fnamemanque    <ENVIRONMENT?>    ; c-addr u -- false | i*x true
  4554. fw_ENVQ:                ; CORE
  4555.     ctok    NEST
  4556.     ctok    TWO_DROP
  4557.     ctok    FALSE            ; don't know nuttin'
  4558.     ctok    UNNEST
  4559.  
  4560. ;--( File Words )
  4561.  
  4562.     include    jx4files.a        ; jax4th.asm is just getting too big!
  4563.  
  4564. ;--( Platform-Specific Stuff )
  4565.  
  4566. ; Copy unicode string to asciiz string in special sys buffer, null terminates
  4567.     sname    <ASCIIZ>        ; c-addr u -- addr
  4568.     ctok    NEST            ; Not in Standard, used for syscalls that don't take unicode
  4569.     ctok    TUCK            ; -- u c-addr u
  4570.     ctok    FALSE            ; -- u c-addr u 0
  4571.     compqdo    asciiz2
  4572. asciiz1:
  4573.     ctok    DUP            ; -- u c-addr c-addr
  4574.     ctok    C_FETCH            ; -- u c-addr char
  4575.     literal    asciizBuffer        ; -- u c-addr char addr
  4576.     ctok    I
  4577.     ctok     PLUS            ; -- u c-addr char addr'
  4578.     ctok    B_STORE            ; -- u c-addr
  4579.     ctok    CHAR_PLUS        ; -- u c-addr'
  4580.     comploop    asciiz1
  4581. asciiz2:
  4582.     ctok    DROP            ; -- u
  4583.     literal    asciizBuffer        ; -- u addr
  4584.     ctok    PLUS            ; -- addr'    one past end of byte string
  4585.     ctok    FALSE
  4586.     ctok    SWAP            ; -- 0 addr'
  4587.     ctok    B_STORE            ; --
  4588.     literal    asciizBuffer        ; -- addr    buffer holding ascii byte string
  4589.     ctok    UNNEST
  4590.  
  4591. ; Copy ascii string to unicode string in special sys buffer, null terminates
  4592.     sname    <UNICODE>        ; b-addr u -- addr
  4593.     ctok    NEST            ; Not in Standard, used for syscalls that don't take unicode
  4594.     ctok    TUCK            ; -- u b-addr u
  4595.     ctok    FALSE            ; -- u b-addr u 0
  4596.     compqdo    unicode2
  4597. unicode1:
  4598.     ctok    DUP            ; -- u b-addr b-addr
  4599.     ctok    B_FETCH            ; -- u b-addr char
  4600.     literal    asciizBuffer        ; -- u b-addr char c-addr
  4601.     ctok    I
  4602.     ctok    CHARS
  4603.     ctok     PLUS            ; -- u c-addr char addr'
  4604.     ctok    C_STORE            ; -- u c-addr
  4605.     ctok    ONE_PLUS        ; -- u c-addr'
  4606.     comploop    unicode1
  4607. unicode2:
  4608.     ctok    DROP            ; -- u
  4609.     literal    asciizBuffer        ; -- u addr
  4610.     ctok    CHARS
  4611.     ctok    PLUS            ; -- addr'    one past end of byte string
  4612.     ctok    FALSE
  4613.     ctok    SWAP            ; -- 0 addr'
  4614.     ctok    C_STORE            ; --
  4615.     literal    asciizBuffer        ; -- addr    buffer holding ascii byte string
  4616.     ctok    UNNEST
  4617.  
  4618.     sname    <SYSCALL>            ; abs-addr -- edx eax
  4619.     docode                    ; Call addr and return eax and edx
  4620.     pushrp    ebx                ; I'm suspicious this isn't loyally preserved
  4621.     pop    eax
  4622.     call    eax
  4623.     push    edx
  4624.     push    eax
  4625.     poprpto    ebx                ; restore
  4626.     next
  4627.  
  4628.     sname    <GetProcAddress>        ; [lpszProc | ordinal] hModule -- abs-addr | nil
  4629.     docode                    ; find a DLL function address from a null-terminated name string
  4630.     call    GetProcAddress            ; parameter if ordinal must have zero (0000h) in hi word
  4631.     push    eax
  4632.     next
  4633.  
  4634.     sname    <LoadLibraryEx>            ; dwFlags 0 lpszLibFile -- hModule | 0
  4635.     docode
  4636.     call    LoadLibraryExW
  4637.     push    eax
  4638.     test    eax,0
  4639.     je    doLastErr            ; if error, set LastError var
  4640.     next
  4641.  
  4642.     sname    <FreeLibrary>            ; hLibModule --
  4643.     docode
  4644.     call    FreeLibrary
  4645.     push    eax
  4646.     test    eax,0
  4647.     je    doLastErr            ; if error, set LastError var
  4648.     next
  4649.  
  4650.     sname    <ENABLE_LINE_INPUT>        ; -- x
  4651.     ctok    DOCONST                ; Con Mode constant value
  4652.     dd    ENABLE_LINE_INPUT
  4653.  
  4654.     sname    <ENABLE_ECHO_INPUT>        ; -- x
  4655.     ctok    DOCONST                ; Con Mode constant value
  4656.     dd    ENABLE_ECHO_INPUT
  4657.  
  4658.     sname    <ENABLE_PROCESSED_INPUT>    ; -- x
  4659.     ctok    DOCONST                ; Con Mode constant value
  4660.     dd    ENABLE_PROCESSED_INPUT
  4661.  
  4662.     sname    <ENABLE_WINDOW_INPUT>        ; -- x
  4663.     ctok    DOCONST                ; Con Mode constant value
  4664.     dd    ENABLE_WINDOW_INPUT
  4665.  
  4666.     sname    <ENABLE_MOUSE_INPUT>        ; -- x
  4667.     ctok    DOCONST                ; Con Mode constant value
  4668.     dd    ENABLE_MOUSE_INPUT
  4669.  
  4670.     sname    <StdIn>                ; -- a-addr
  4671.     ctok    DOCONST                ; Con stdin
  4672.     dd    stdIn
  4673.  
  4674.     sname    <StdOut>            ; -- a-addr
  4675.     ctok    DOCONST                ; Con stdout
  4676.     dd    stdOut
  4677.  
  4678.     sname    <StdErr>            ; -- a-addr
  4679.     ctok    DOCONST                ; Con stdErr
  4680.     dd    stdErr
  4681.  
  4682.     sname    <ConsoleMode>            ; -- a-addr
  4683.     ctok    DOCONST                ; Address of Con Mode variable
  4684.     dd    conMode                ; Implementation
  4685.  
  4686.     sname    <LastError>            ; -- a-addr
  4687.     ctok    DOCONST                ; Address of Last Error variable
  4688.     dd    lastError            ; Implementation
  4689.  
  4690.     sname    <GetConsoleMode>        ; -- LastErr | TRUE
  4691.     docode                    ; Implementation
  4692.     lea    eax,[dp+conMode]
  4693.     INVOKE    GetConsoleMode, [dp+stdIn], eax
  4694.     jmp    SHORT    retLastErr        ; returns to NEXT via doLastErr
  4695.  
  4696.     sname    <SetConsoleMode>        ; -- LastErr | TRUE
  4697.     docode                    ; Implementation
  4698.     mov    eax,[dp+conMode]
  4699.     INVOKE    SetConsoleMode, [dp+stdIn], eax
  4700.     jmp    SHORT    retLastErr        ; returns to NEXT via doLastErr
  4701.  
  4702. ; Set our local LastError variable either TRUE for success or to return from LastError, return same on stack
  4703. retLastErr:
  4704.     and    eax,eax                ; "C" TRUE is success
  4705.     je    rLE1                ; on failure, get error code
  4706.     mov    DWORD PTR lastError[dp],TRUE    ; success, return TRUE
  4707.     mov    eax,TRUE
  4708.     push    TRUE
  4709.     next                    ; No Windows error code has all bits set
  4710. rLE1:    INVOKE    GetLastError
  4711.     mov    lastError[dp],eax        ; save error return
  4712.     push    eax
  4713.     next
  4714.  
  4715. ;--( Startup & Signoff )
  4716.  
  4717.     zname    <LOGIN>
  4718.     docode
  4719.     INVOKE    WriteConsoleW, [dp+stdErr], OFFSET FLAT:myMsg,myMsgLen, OFFSET FLAT:numWritten, 0
  4720.     next
  4721.  
  4722.     nname    <ABOUT>
  4723.     docode
  4724.     INVOKE    WriteConsoleW, [dp+stdErr], OFFSET FLAT:gnuMsg, gnuMsgLen, OFFSET FLAT:numWritten, 0
  4725.     next
  4726.  
  4727.     nname    <COLD>
  4728.     ctok    NEST
  4729. cold:    ctok    GetConsoleMode    ; set up our variable that tracks the console input mode
  4730.     ctok    DROP        ; discard return
  4731.     ctok    DECIMAL        ; set number conversion base to decimal, set early to aid debugging
  4732.     ctok    FALSE
  4733.     ctok    BLK        ; input is not from a BLOCK file
  4734.     ctok    STORE
  4735.     ctok    FALSE
  4736.     ctok    SOURCE_ID    ; input is from keyboard
  4737.     ctok    STORE
  4738.     literal    ticktib
  4739.     ctok    TICK_TIB    ; set up pointer to terminal input buffer
  4740.     ctok    STORE
  4741.     ctok    FALSE
  4742.     ctok    NUMTIB        ; no chars in terminal input buffer
  4743.     ctok    STORE
  4744.     ctok    FALSE
  4745.     ctok    TO_IN        ; no index into zero chars
  4746.     ctok    STORE
  4747.     ctok    FALSE
  4748.     ctok    STATE        ; interpreting, not compiling
  4749.     ctok    STORE
  4750.     ctok    FALSE
  4751.     literal    endq        ; not end of input
  4752.     ctok    STORE
  4753.     ctok    EMPTYBUFFERS    ; clear block buffer(s)
  4754.     ctok    FALSE
  4755.     literal    blockFile
  4756.     ctok    STORE        ; no active block file
  4757.     ctok     FIRSTCATCH    ; set up initial catch frame
  4758.     ctok    INITDEFERS    ; all the deferred words
  4759.     ctok    ONLY        ; set default search order
  4760.     ctok    DEFINITIONS    ; set default compilation order
  4761.     ctok    SWORDLIST
  4762.     ctok    NWORDLIST
  4763.     ctok    FWORDLIST
  4764.     literal    3
  4765.     ctok    SET_ORDER
  4766. cold1:    ctok    LSHARP        ; set up number conversion buffer
  4767.     ctok    GETCOMMANDLINE    ; -- c-addr u
  4768.     ctok    NUMTIB
  4769.     ctok    STORE
  4770.     ctok    TICK_TIB
  4771.     ctok    STORE
  4772.     ctok    BL
  4773.     ctok    WORD
  4774.     ctok    DROP        ; -- , eliminate filename from command line
  4775.     ctok    INTERPRET    ; -- interpret, ABORT will clean up
  4776. ;    ctok    PAGE
  4777.     ctok    LOGIN        ; display signon message including copyright
  4778.     ctok    ABOUT
  4779.     ctok    okPrompt
  4780.     ctok    QUIT
  4781.  
  4782. zname    <INITDEFERS>        ; -- , init all deferred vectors
  4783.     ctok    NEST
  4784.     ctok    DOLIT
  4785.     ctok    FILEPOSITIONW
  4786.     ctok    DOLIT
  4787.     ctok    FILEPOSITION
  4788.     ctok    TO_BODY
  4789.     ctok    STORE        ; Init FILE-POSITION
  4790.     ctok    DOLIT
  4791.     ctok    FILESIZEW
  4792.     ctok    DOLIT
  4793.     ctok    FILESIZE
  4794.     ctok    TO_BODY
  4795.     ctok    STORE        ; Init FILE-SIZE
  4796.     ctok    DOLIT
  4797.     ctok    READFILEW
  4798.     ctok    DOLIT
  4799.     ctok    READFILE
  4800.     ctok    TO_BODY
  4801.     ctok    STORE        ; Init READ-FILE
  4802.     ctok    DOLIT
  4803.     ctok    REPOFILEW
  4804.     ctok    DOLIT
  4805.     ctok    REPOFILE
  4806.     ctok    TO_BODY
  4807.     ctok    STORE        ; Init REPOSITION-FILE
  4808.     ctok    DOLIT
  4809.     ctok    RESIZEFILEW
  4810.     ctok    DOLIT
  4811.     ctok    RESIZEFILE
  4812.     ctok    TO_BODY
  4813.     ctok    STORE        ; Init RESIZE-FILE
  4814.     ctok    DOLIT
  4815.     ctok    WRITEFILEW
  4816.     ctok    DOLIT
  4817.     ctok    WRITEFILE
  4818.     ctok    TO_BODY
  4819.     ctok    STORE        ; Init WRITE-FILE
  4820.     ctok    UNNEST
  4821.  
  4822. ;--( Save and Restore Input )
  4823.  
  4824.     fnamemanque    <SAVE-INPUT>    ; -- xn .. x1 n
  4825. fw_SAVEINP:                ; CORE EXT
  4826.     ctok    NEST
  4827.     ctok    TIB
  4828.     ctok    NUMTIB
  4829.     ctok    FETCH
  4830.     ctok    TO_IN
  4831.     ctok    FETCH
  4832.     literal    endq
  4833.     ctok    FETCH
  4834.     ctok    BLK
  4835.     ctok    FETCH
  4836.     ctok    SOURCE_ID
  4837.     ctok    FETCH
  4838.     literal    6
  4839.     ctok    UNNEST
  4840.  
  4841.     fnamemanque    <RESTORE-INPUT>    ; -- xn .. x1 n
  4842. fw_RESTINP:                ; CORE EXT
  4843.     ctok    NEST
  4844.     ctok    DROP
  4845.     ctok    SOURCE_ID
  4846.     ctok    STORE
  4847.     ctok    BLK
  4848.     ctok    STORE
  4849.     literal    endq
  4850.     ctok    STORE
  4851.     ctok    TO_IN
  4852.     ctok    STORE
  4853.     ctok    NUMTIB
  4854.     ctok    STORE
  4855.     ctok    TICK_TIB
  4856.     ctok    STORE
  4857.     ctok    UNNEST
  4858.  
  4859. ;--( Saving and Restoring Images )
  4860.  
  4861.     nnamemanque    <SAVE-FORTH>    ; -- 0|error
  4862. fw_SAVEFORTH:
  4863.     docode
  4864.     store    var_tib,ticktib            ; loaded image comes back with normal inputbuff
  4865.     store    var_numtib,0            ; loaded image comes back with no chars in buffer
  4866.     store    var_to_in,0            ; no words parsed
  4867.     store    endq,0                ; nuttin' happenin'
  4868.     store    var_blk,0            ; no block
  4869.     store    var_srcid,0            ; no file
  4870.     store    lastError,0            ; no error
  4871.     store    zeroBuffer,002E002Ah        ; init file title string to "*.*\0"
  4872.     store    (zeroBuffer+cell),0000002Ah
  4873.     mov    eax,zeroBuffer            ; data address of buffer
  4874.     add    eax,dp                ; convert to abs address
  4875.     mov    edx,OFFSET FLAT:saveFile    ; address of OPENFILENAME struct
  4876.     mov    [edx].OPENFILENAME.lpstrFile,eax    ; init w/ptr to string
  4877.     INVOKE    GetSaveFileNameW,edx        ; get string of file name to save
  4878.     and    eax,eax
  4879.     je    saveferr
  4880.     mov    eax,zeroBuffer            ; data address of buffer
  4881.     add    eax,dp                ; convert to abs address
  4882.     INVOKE    CreateFileW, eax, GENERIC_WRITE, 0, OFFSET FLAT:secAttrib, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0
  4883.     cmp    eax,INVALID_HANDLE_VALUE
  4884.     je    saveferr1        ; if handle is invalid, branch away
  4885.     push    eax            ; save file handle
  4886.     INVOKE    WriteFile, eax, cp, defDataSize+defDictSize, OFFSET FLAT:numRead, 0
  4887.     and    eax,eax            ; did we write ok?
  4888.     jne    saveforth1        ; if TRUE, it's ok, branch onwards
  4889.     INVOKE    GetLastError        ; if FALSE, error, get it
  4890.     mov    edx,eax            ; save the error
  4891.     store    lastError,eax        ; keep copy in lastError
  4892.     pop    eax            ; get back file handle
  4893.     push    edx            ; here's the last error return to exit word with
  4894.     INVOKE    CloseHandle,eax        ; close the file handle
  4895.     next                ; return that error code we left on stack
  4896. saveforth1:                ; we wrote ok
  4897.     pop    eax            ; get file handle back
  4898.     INVOKE    CloseHandle,eax        ; close the file handle
  4899. saveforthdone:
  4900.     xor    eax,eax            ; make a zero, we don't care what CloseHandle did
  4901.     push    eax            ; return success
  4902.     next
  4903. saveferr:
  4904.     store    lastError, userErr    ; an error code that no Windows API returns
  4905.     INVOKE    CommDlgExtendedError    ; get dialog error
  4906.     push    eax            ; push error ior
  4907.                     ; but don't store in lastError, shows diff from GetLastError
  4908.     next
  4909. saveferr1:
  4910.     INVOKE    GetLastError        ; if FALSE, error, get it
  4911.     store    lastError,eax        ; keep copy in lastError, this is a GetLastError err
  4912.     push    eax            ; push error ior
  4913.     next
  4914.  
  4915.     znamemanque    <SAVE-CON>    ; -- x1 .. xn
  4916. fw_SAVECON:                ; save console and other specs
  4917.     ctok    NEST
  4918.     literal    lastCatch        ; holds catch frame pointer
  4919.     ctok    FETCH
  4920.     literal    lastCaught        ; holds IP pointing to cell following THROW
  4921.     ctok    FETCH
  4922.     literal    conMode            ; Holds Console Mode
  4923.     ctok    FETCH
  4924.     literal    ntConEBP        ; holds value of EBP from startup
  4925.     ctok    FETCH
  4926.     literal    ntConESP        ; holds value of ESP from startup
  4927.     ctok    FETCH
  4928.     literal    memHandle        ; pointer to allocated memory block
  4929.     ctok    FETCH
  4930.     literal    stdIn            ; Console handle
  4931.     ctok    FETCH
  4932.     literal    stdOut            ; Console handle
  4933.     ctok    FETCH
  4934.     literal    stdErr            ; Console handle
  4935.     ctok    FETCH
  4936.     ctok    SP0            ; initial SP
  4937.     ctok    FETCH
  4938.     literal    rpzero            ; initial RP
  4939.     ctok    FETCH
  4940.     ctok    UNNEST
  4941.  
  4942.     znamemanque    <RESTORE-CON>    ; x1 .. xn --
  4943. fw_RESTCON:                ; Restore console and other specs
  4944.     ctok    NEST
  4945.     literal    rpzero            ; initial RP
  4946.     ctok    STORE
  4947.     ctok    SP0            ; initial SP
  4948.     ctok    STORE
  4949.     literal    stdErr            ; Console handle
  4950.     ctok    STORE
  4951.     literal    stdOut            ; Console handle
  4952.     ctok    STORE
  4953.     literal    stdIn            ; Console handle
  4954.     ctok    STORE
  4955.     literal    memHandle        ; pointer to allocated memory block
  4956.     ctok    STORE
  4957.     literal    ntConESP        ; holds value of ESP from startup
  4958.     ctok    STORE
  4959.     literal    ntConEBP        ; holds value of EBP from startup
  4960.     ctok    STORE
  4961.     literal    conMode            ; Holds Console Mode
  4962.     ctok    STORE
  4963.     literal    lastCaught        ; holds IP pointing to cell following THROW
  4964.     ctok    STORE
  4965.     literal    lastCatch        ; holds catch frame pointer
  4966.     ctok    STORE
  4967.     ctok    UNNEST
  4968.  
  4969.     snamemanque    <RELOAD-FILE>        ; file-id -- u ior
  4970. fw_RELOADFILE:            
  4971.     ctok    NEST                ; reloads an image from file-id
  4972.     ctok    TO_R                ; --            R: -- fid
  4973.     ctok    SAVECON                ; -- x1 .. xn        R: -- fid
  4974.     ctok    R_FROM                ; -- x1 .. xn fid    R: --
  4975.     literal    0
  4976.     ctok    CODETODATA            ; -- x1 .. xn fid a-addr, base of user image
  4977.     literal    (defDataSize+defDictSize)    ; -- x1 .. xn fid a-addr u, size of user image in bytes
  4978.     ctok    ROT                ; -- x1 .. xn c-addr u fid
  4979.     ctok    READFILEA            ; -- x1 .. xn u ior
  4980.     ctok    TWO_TO_R            ; -- x1 .. xn        R: -- u ior
  4981.     ctok    RESTCON                ; --            R: -- u ior
  4982.     ctok    TWO_R_FROM            ; -- u ior        R: --
  4983.     ctok    UNNEST
  4984.  
  4985. sname    <RELOADED>            ; c-addr u -- u ior1 ior2
  4986.     ctok    NEST            ; reload image from name file
  4987.     ctok    RO            ; -- c-addr u fam
  4988.     ctok    OPENFILE        ; -- fid ior
  4989.     compif    reloaded1
  4990.     literal    -37
  4991.     ctok    THROW
  4992. reloaded1:                ; -- fid
  4993.     ctok    DUP            ; -- fid fid
  4994.     ctok    RELOADFILE        ; -- fid u ior
  4995.     ctok    ROT            ; -- u ior fid
  4996.     ctok    CLOSEFILE        ; -- u ior1 ior2
  4997.     ctok     UNNEST    
  4998.  
  4999.     sname    <RELOAD>        ; "ccc< >" --
  5000.     ctok    NEST            ; use on NT command line only, otherwise crap in TIB
  5001.     ctok    BL
  5002.     ctok    WORD
  5003.     ctok    TO_R            ; --            R: -- c-addr
  5004.     ctok    SAVEINP            ; -- n*x n
  5005.     ctok    R_FROM            ; -- n*x n c-addr
  5006.     ctok    COUNT            ; -- n*x n c-addr' u
  5007.     ctok    RELOADED        ; -- n*x n u ior1 ior2
  5008.     ctok    TWO_DROP        ; -- n*x n ior
  5009.     ctok    DROP            ; -- n*x n
  5010.     ctok    RESTINP            ; --
  5011.     ctok    UNNEST
  5012.  
  5013.     sname    <GETCOMMANDLINE>    ; -- c-addr u
  5014.     docode
  5015.     INVOKE    GetCommandLineW
  5016.     push    eax                ; push address of command line
  5017.     sub    DWORD PTR [esp],dp        ; convert to data-relative address
  5018.     mov    ecx,eax
  5019.     .WHILE    ( WORD PTR [eax] != 0 )    ; find null at end of string
  5020.     add    eax,tchar
  5021.     .ENDW
  5022.     xor    edx,edx
  5023.     sub    eax,ecx
  5024.     mov    ecx,2
  5025.     div    ecx
  5026.     push    eax
  5027.     next
  5028.  
  5029. ;--( Bootup )
  5030.  
  5031. boot:                        ; initialize system
  5032.     INVOKE    LocalAlloc, LMEM_FIXED, defDataSize+defDictSize    ; get mem for user dictionary & data space
  5033.     mov    cp,eax                ; return if non-null is user dictionary, must test here
  5034.     lea    dp,[eax+defDictSize]        ; data space
  5035.     store    memHandle,eax            ; save copy of mem handle for later free
  5036.     store    ntConEBP,ebp            ; preserve EBP
  5037.     store    ntConESP,esp            ; preserve ESP
  5038.     lea    rp,[esp-dStackSize]        ; set return stack pointer
  5039.     store    rpzero,rp            ; save initial return stack
  5040.     INVOKE    GetStdHandle, STD_INPUT_HANDLE    ; return is handle or INVALID_HANDLE
  5041.     store    stdIn,eax            ; store handle
  5042.     INVOKE    GetStdHandle, STD_OUTPUT_HANDLE    ; return is handle or INVALID_HANDLE
  5043.     store    stdOut,eax            ; store handle
  5044.     INVOKE    GetStdHandle, STD_ERROR_HANDLE    ; return is handle or INVALID_HANDLE
  5045.     store    stdErr,eax            ; store handle
  5046.  
  5047. ; !!!***!!! for now, just fall thru here into bare_boot
  5048.  
  5049. bare_boot:                    ; if we aren't loading a saved image
  5050.     store    datap,varptr            ; set HERE
  5051.     store    dictp,0                ; offset end of dictionary
  5052.     store    wllink,<OFFSET FLAT:fw_SWORDLIST>    ; word list link
  5053.     mov    DWORD PTR [dp+flinkp],flinkptr    ; last link in FORTH-WORDLIST
  5054.     mov    DWORD PTR [dp+zlinkp],zlinkptr    ; last link in INTERNALS-WORDLIST
  5055.     mov    DWORD PTR [dp+nlinkp],nlinkptr    ; last link in NONSTANDARD-WORDLIST
  5056.     mov    DWORD PTR [dp+slinkp],slinkptr    ; last link in SYSTEM-WORDLIST
  5057.     mov    ecx,searchOrderSize        ; set up to clear search order
  5058.     xor    eax,eax                ; 0
  5059.     lea    edx,searchOrder[dp]        ; address of base of search order array
  5060. bb1:    mov    [edx],eax            ; erase a cell
  5061.     add    edx,cell            ; increment address
  5062.     loop    bb1                ; loop till done
  5063.  
  5064. dev_boot:
  5065.     mov    WORD PTR lastReadConW,UniNotAChar
  5066.     mov    ip,OFFSET FLAT:cold
  5067.     next
  5068.  
  5069. _main    ENDP
  5070.  
  5071. _TEXT    ENDS
  5072.  
  5073. END
  5074.